Updated gir2pascal to add the parameter error: PPGError to functions if throws=1 is set as a property name

https://bugzilla.gnome.org/show_bug.cgi?id=721588
Added support for the new parameter type "instance-parameter" which is similiar to the hidden "self" param of pascal


git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2876 8e941d3f-bd1b-0410-a28a-d453659cc2b4

applications/gobject-introspection/gir2pascal.lpi

@@ -1,4 +1,4 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
     <Version Value="9"/>

applications/gobject-introspection/girerrors.pas

@@ -34,6 +34,7 @@ type
     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"';
+    geAddingErrorNode = '%s %s throws an error but is not included as a param. Adding...';
 
   var
     girErrorName: array[TGirError] of String =(

applications/gobject-introspection/girobjects.pas

@@ -106,14 +106,17 @@ type
 
   TgirTypeParam = class(TGirBaseType)
   private
+    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;
   end;
 
   { TgirProperty }
@@ -199,6 +202,7 @@ type
   TGirFunctionParam = class(TgirTypeParam)
   public
     constructor Create(AOwner: TObject; ANode: TDomNode); override;
+    constructor Create(AOwner: TObject; ANode: TDomNode; AIsInstanceParam: Boolean); override;
   end;
 
   { TgirFunctionReturn }
@@ -226,6 +230,7 @@ type
     FDeprecatedVersion: String;
     FParams: TgirParamList;
     FReturns: TgirFunctionReturn;
+    FThrowsGError: Boolean;
   publiC
     constructor Create(AOwner: TObject; ANode: TDomNode); override;
     destructor Destroy; override;
@@ -235,6 +240,7 @@ type
     property Deprecated: Boolean read FDeprecated;
     property DeprecatedMsg: String read FDeprecatedMsg;
     property DeprecatedVersion: String read FDeprecatedVersion;
+    property ThrowsGError: Boolean read FThrowsGError write FThrowsGError;
   end;
 
   { TgirMethod }
@@ -374,7 +380,7 @@ type
 
 
 implementation
-uses girNameSpaces, girErrors;
+uses girNameSpaces, girErrors, XMLRead;
 
 { TgirClassStruct }
 
@@ -773,6 +779,12 @@ begin
   FObjectType:=otFunctionParam;
 end;
 
+constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode;
+  AIsInstanceParam: Boolean);
+begin
+  inherited Create(AOwner, ANode, AIsInstanceParam);
+end;
+
 { TgirTypeParam }
 
 function TgirTypeParam.GetType: TGirBaseType;
@@ -891,6 +903,13 @@ begin
   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);
@@ -898,6 +917,46 @@ 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;
@@ -913,9 +972,16 @@ var
             Param := TGirFunctionParam.Create(AOwner, PNode);
             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;
@@ -924,6 +990,7 @@ 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]);
 

applications/gobject-introspection/girpascalwritertypes.pas

@@ -213,7 +213,7 @@ type
     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 WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil; AIncludeInstanceParam: Boolean = False): String;
     function WriteFunction(AFunction: TgirFunction; AItem: TGirBaseType; AIsMethod: Boolean; AWantWrapperForObject: Boolean; AFunctionList: TStrings; AExistingUsedNames: TStringList = nil): String;
     function WriteParamAsString(AParam: TgirTypeParam; AIndex: Integer;  out ABitSizeSpecified: Boolean; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
     function WriteRecord(ARecord: TgirRecord; ABaseIndent: Integer = 0; AIsUnion: Boolean = False): String;
@@ -1144,10 +1144,14 @@ var
   Postfix: String;
   Entry: String;
   InLineS: String = '';
-  Deprecated: String = '';
+  DeprecatedS: String = '';
   ProperUnit: TPascalUnit;
   OptionsIndicateWrapperMethod: Boolean;
 begin
+  { I apologize to anyone who tries to figure all this out. In short this function
+    writes procedure lines for an object and it's implementation. As well as the
+    plain function the object method calls.
+  }
   Result := '';
   OptionsIndicateWrapperMethod:= FUnitType = PascalUnitTypeAll;
   // we skip deprecated functions
@@ -1164,7 +1168,7 @@ begin
   if AWantWrapperForObject then
     InLineS:=' inline;';
 
-  if AFunction.Deprecated then Deprecated :=' deprecated ''Since ' + NameSpace.NameSpace + ' ' + AFunction.DeprecatedVersion+' '+StringReplace(AFunction.DeprecatedMsg,'''','`', [rfReplaceAll])+''';';
+  if AFunction.Deprecated then DeprecatedS :=' deprecated ''Since ' + NameSpace.NameSpace + ' ' + AFunction.DeprecatedVersion+' '+StringReplace(AFunction.DeprecatedMsg,'''','`', [rfReplaceAll])+''';';
   // this fills in the values for procedure/function and the return type
   WriteFunctionTypeAndReturnType(AFunction, RoutineType, Returns);
 
@@ -1172,13 +1176,13 @@ begin
   if AFunction.InheritsFrom(TgirConstructor) then
     Returns := ': '+MakePascalTypeFromCType(AItem.TranslatedName ,1)+'; cdecl;';
 
-  Params := WriteFunctionParams(AFunction.Params);
+  Params := WriteFunctionParams(AFunction.Params, nil, False);
   if Pos('array of const', Params) + Pos('va_list', Params) > 0 then
     Prefix:='//';
   if not (goLinkDynamic in FOptions) then
-    Postfix := ' external;'+ Deprecated// '+UnitName+'_library;';
+    Postfix := ' external;'+ DeprecatedS// '+UnitName+'_library;';
   else
-    PostFix := ''+Deprecated;
+    PostFix := ''+DeprecatedS;
 
   // first wrapper proc
   Entry := Prefix + RoutineType +' '+ SanitizeName(AFunction.Name, AExistingUsedNames)+ParenParams(Params)+Returns+InLineS;
@@ -1190,18 +1194,24 @@ begin
   // This is the line that will be used by in the TObject declaration. <----
   // result will be written in the object declaration.
   if OptionsIndicateWrapperMethod and not(goNoWrappers in FOptions) then
-    Result := Entry + Deprecated
+    Result := Entry + DeprecatedS
   else
     Result := '';
 
   // 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
+    // with older introspection versions methods do not include the first param for it's type so we have to add it
+    if (AFunction.Params.Count = 0) // <--only true if older
+    or ((AFunction.Params.Count > 0) and not(AFunction.Params.Param[0].IsInstanceParam)) then // <-- true if older
+    begin
       if Params <> '' then
         Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1)+'; ' + Params
       else
         Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1);
+    end
+    else
+      Params := WriteFunctionParams(AFunction.Params, nil, True);
   end;
 
   ProperUnit := FGroup.GetUnitForType(utFunctions);
@@ -1625,7 +1635,7 @@ var
 begin
   if AWantSelf then
   begin
-    if AParams.Count = 0 then
+    if (AParams.Count = 0) or ((AParams.Count = 1) and AParams.Param[0].IsInstanceParam) then
       CallParams:='@self'
     else
       CallParams:='@self, ';
@@ -1634,11 +1644,12 @@ begin
     CallParams:='';
   if (ARoutineType = 'function') or (ARoutineType='constructor') then
     ResultStr := 'Result := ';
-  Params:=WriteFunctionParams(AParams, @Args);
+  Params:=WriteFunctionParams(AParams, @Args, not AWantSelf);
   CallParams:=CallParams+Args;
   Code := TPCodeText.Create;
   Code.Content := Format(Decl, [ARoutineType, AObjectName, AObjectFunctionName, ParenParams(Params), AFunctionReturns])+
-                  Format(Body, [ResultStr, FGroup.UnitForType[utFunctions].UnitFileName+'.'+AFlatFunctionName, CallParams]);
+                  Format(Body, [ResultStr, FGroup.UnitForType[utFunctions].UnitFileName+'.'+AFlatFunctionName,
+                  CallParams]);
   ImplementationSection.Declarations.Add(Code);
 
 
@@ -1690,7 +1701,7 @@ begin
   end;
 end;
 
-function TPascalUnit.WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil): String;
+function TPascalUnit.WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil; AIncludeInstanceParam: Boolean = false): String;
 var
   i: Integer;
   ArgName: String;
@@ -1701,7 +1712,13 @@ begin
     AArgs^ := '';
   for i := 0 to AParams.Count-1 do
     begin
-      Result := Result+WriteParamAsString(AParams.Param[i], i, Dummy, @ArgName);
+      // IsInstanceParam is only the ever the first param so this is safe if it's the
+      // only Param and AArgs is not updated. AArgs := @Self[, ;] is set in WriteFunction
+      if AIncludeInstanceParam or (not AIncludeInstanceParam and not AParams.Param[i].IsInstanceParam) then
+        Result := Result+WriteParamAsString(AParams.Param[i], i, Dummy, @ArgName)
+      else
+        Continue;
+
       if i < AParams.Count-1 then
       begin
         Result := Result +'; ';

applications/gobject-introspection/girtokens.pas

@@ -28,7 +28,7 @@ uses
 type
   TGirToken = (gtInvalid, gtAlias, gtConstant, gtRecord, gtBitField, gtEnumeration,
                gtCallback, gtUnion, gtFunction, gtReturnValue, gtType,
-               gtParameters, gtParameter, gtMember, gtField, gtMethod, gtArray,
+               gtParameters, gtParameter, gtInstanceParameter, gtMember, gtField, gtMethod, gtArray,
                gtDoc, gtConstructor, gtRepository, gtInclude, gtNameSpace, gtPackage,
                gtCInclude, gtClass, gtProperty, gtVirtualMethod, gtInterface,
                gtGlibSignal, gtImplements, gtPrerequisite,gtVarArgs, gtObject, gtClassStruct, gtGType);
@@ -50,6 +50,7 @@ var
     'type',
     'parameters',
     'parameter',
+    'instance-parameter',
     'member',
     'field',
     'method',