-----------------------------------------------------------------------
--                   Gate - GtkAda Components                        --
--                                                                   --
--   Copyright (C) 1999-2000 E. Briot, J. Brobecker and A. Charlet   --
--                Copyright (C) 2000-2003 ACT-Europe                 --
--                                                                   --
-- GATE 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 library; --
-- if not,  write to the  Free Software Foundation, Inc.,  59 Temple --
-- Place - Suite 330, Boston, MA 02111-1307, USA.                    --
-----------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings.Fixed; use Ada.Strings; use Ada.Strings.Fixed;
with Glib.Object; use Glib.Object;

package body Glib.Glade is

   subtype Package_Range is Natural range 1 .. 1000;
   subtype Signal_Range is Natural range 1 .. 1000;

   Packages : array (Package_Range) of String_Ptr;
   Num_Packages : Natural := 0;
   --  Use by Add_Package and Gen_Packages to register all the packages
   --  referenced and print them

   type Instantiation_Rec is record
      Instantiation : String_Ptr;
      Rename        : String_Ptr;
   end record;
   --  If this instantiation is a rename, Rename is the name of the
   --  original signal instantiation to rename. It is null otherwise.

   Signal_Instantiations : array (Signal_Range) of Instantiation_Rec;
   Num_Signal_Instantiations : Natural := 0;
   --  Used by Add_Signal_Instantiation and Gen_Signal_Instantiations

   type Signal_Rec is record
      Widget : Node_Ptr;
      Handler, Signal, Class, Orig_Class : String_Ptr;
   end record;

   Signals : array (Signal_Range) of Signal_Rec;
   Num_Signals : Natural := 0;
   --  Used by Add_Signal and Gen_Signal_Instantiations

   function Add_Signal
     (Widget : Node_Ptr;
      Handler, Signal, Class, Orig_Class : String_Ptr) return String_Ptr;
   --  Add a specific handler of signal of a given class in Signals.
   --  If Handler is already present in the list of signals for the same
   --  top level widget, do not add it and return the class associated with
   --  the handler found, return null otherwise.
   --
   --  Widget is the node of the top level widget containing the signal.
   --  Orig_Class is the original class for the signal. If Orig_Class
   --  is different from Class, Class is the class of the widget passed
   --  to the callback using Object_Connect.

   procedure Add_Signal_Instantiation
     (S      : String_Ptr;
      Rename : String_Ptr := null);
   --  Add class S in Signal_Instantiation if not already present or if
   --  Rename isn't null.

   --------------
   -- Get_Part --
   --------------

   function Get_Part
     (S : String; Part : Positive; Separator : Character := ':') return String
   is
      Count : Natural := 0;
      First : Positive := S'First;

   begin
      for J in S'Range loop
         if S (J) = Separator then
            Count := Count + 1;

            if Count = Part then
               return S (First .. J - 1);
            else
               First := J + 1;
            end if;
         end if;
      end loop;

      if Count + 1 = Part then
         return S (First .. S'Last);
      else
         return "";
      end if;
   end Get_Part;

   -----------------
   -- Add_Package --
   -----------------

   procedure Add_Package (S : String) is
   begin
      for J in 1 .. Num_Packages loop
         if Packages (J).all = S then
            return;
         end if;
      end loop;

      Num_Packages := Num_Packages + 1;
      Packages (Num_Packages) := new String '(S);
   end Add_Package;

   ----------------
   -- Add_Signal --
   ----------------

   function Add_Signal
     (Widget : Node_Ptr;
      Handler, Signal, Class, Orig_Class : String_Ptr) return String_Ptr is
   begin
      for J in 1 .. Num_Signals loop
         if Signals (J).Widget = Widget
           and then Signals (J).Handler.all = Handler.all
         then
            return Signals (J).Class;
         end if;
      end loop;

      Num_Signals := Num_Signals + 1;
      Signals (Num_Signals).Widget     := Widget;
      Signals (Num_Signals).Handler    := Handler;
      Signals (Num_Signals).Signal     := Signal;
      Signals (Num_Signals).Class      := Class;
      Signals (Num_Signals).Orig_Class := Orig_Class;
      return null;
   end Add_Signal;

   ------------------------------
   -- Add_Signal_Instantiation --
   ------------------------------

   procedure Add_Signal_Instantiation
     (S      : String_Ptr;
      Rename : String_Ptr := null) is
   begin
      for J in 1 .. Num_Signal_Instantiations loop
         if Signal_Instantiations (J).Instantiation.all = S.all then
            --  Do not rename ourselves...

            if Rename = null or else Rename.all /= S.all then
               Signal_Instantiations (J).Rename := Rename;
            end if;

            return;
         end if;
      end loop;

      Num_Signal_Instantiations := Num_Signal_Instantiations + 1;
      Signal_Instantiations (Num_Signal_Instantiations) := (S, Rename);
   end Add_Signal_Instantiation;

   ------------
   -- Adjust --
   ------------

   function Adjust (S : String) return String is
      T : String (1 .. S'Length + 4096);
      K : Natural := 1;

   begin
      for J in S'Range loop
         if S (J) = ASCII.LF then
            T (K .. K + 15) := """ & ASCII.LF" & ASCII.LF & "& """;
            K := K + 16;

         --  Skip additional CR present on Win32

         elsif S (J) = '"' then
            T (K .. K + 1) := """""";
            K := K + 2;

         elsif S (J) /= ASCII.CR then
            T (K) := S (J);
            K := K + 1;
         end if;
      end loop;

      return T (1 .. K - 1);
   end Adjust;

   -----------------
   -- Find_Parent --
   -----------------

   function Find_Parent (N : Node_Ptr; Class : String) return Node_Ptr is
      P : Node_Ptr := N.Child;

   begin
      while P /= null loop
         if P.Tag.all = "class" then

            --  In some cases, Glade will have the child_name be the full name
            --  (e.g GtkDialog), whereas in some other cases it deletes the
            --  prefix (e.g Dialog). We have to handle both cases here

            if P.Value.all = Class then
               return P;

            --  Class can be shorter than the real class name

            elsif (P.Value'Length >= Class'Length + 3 and then
                P.Value (P.Value'First + 3 .. P.Value'First + 2 + Class'Length)
                  = Class)

            --  Take into account e.g Gtk[VH]Box

              or else P.Value (P.Value'First + 4 .. P.Value'Last) = Class
            then
               return P;
            else
               exit;
            end if;
         end if;

         P := P.Next;
      end loop;

      if N.Parent /= null then
         return Find_Parent (N.Parent, Class);
      else
         return null;
      end if;
   end Find_Parent;

   ---------------------
   -- Find_Top_Widget --
   ---------------------

   function Find_Top_Widget (N : Node_Ptr) return Node_Ptr is
      P, Q : Node_Ptr;
   begin
      Q := N;
      P := N.Parent;

      if P /= null then
         while P.Tag.all /= "glade-interface" loop
            Q := P;
            P := P.Parent;
         end loop;
      end if;

      return Q;
   end Find_Top_Widget;

   ----------------
   -- Find_Child --
   ----------------

   function Find_Child (N : Node_Ptr; Tag : String) return Node_Ptr is
      P    : Node_Ptr := N;
      Node : Node_Ptr;

   begin
      if N.Tag.all = Tag then
         return N;
      end if;

      while P /= null loop
         if P.Tag.all = Tag then
            return P;
         end if;

         if P.Child /= null then
            Node := Find_Child (P.Child, Tag);

            if Node /= null then
               return Node;
            end if;
         end if;

         P := P.Next;
      end loop;

      return null;
   end Find_Child;

   ------------
   -- To_Ada --
   ------------

   function To_Ada (S : String; Separator : Character := '_') return String is
      First   : Positive;
      K       : Positive := 2;
      Last    : Integer := 0;
      R       : String (1 .. S'Length * 2);
      Has_Sep : Boolean;

      function Has_Separator (S : String) return Boolean;

      function Has_Separator (S : String) return Boolean is
      begin
         for J in S'Range loop
            if S (J) = Separator then
               return True;
            end if;
         end loop;

         return False;
      end Has_Separator;

   begin
      if S'Length = 0 then
         return S;
      end if;

      Has_Sep := Has_Separator (S);

      if S'Length > 4 and then
        (S (S'First .. S'First + 3) = "GTK_"
          or else S (S'First .. S'First + 3) = "GDK_")
      then
         First := S'First + 4;
      else
         First := S'First;
      end if;

      R (1) := To_Upper (S (First));

      for J in First + 1 .. S'Last loop
         --  Add a separator if the separator is not nul, if the current
         --  character is in upper case and if the string doesn't have any
         --  separator.

         if Separator /= ASCII.NUL and then Is_Upper (S (J))
           and then not Has_Sep and then J /= Last + 1
         then
            R (K) := Separator;
            K := K + 1;
            Last := J;
         end if;

         if S (J) = '-' then
            R (K) := Separator;
         else
            if R (K - 1) = Separator then
               R (K) := To_Upper (S (J));
            else
               R (K) := To_Lower (S (J));
            end if;
         end if;

         K := K + 1;
      end loop;

      return R (1 .. K - 1);
   end To_Ada;

   --------------
   -- To_Float --
   --------------

   function To_Float (S : String) return String is
      Exponentiated  : constant Boolean := Index (S, "e") /= 0;
      Mantissa_Start : Natural := 0;
   begin
      --  If the value is a power of 10 and >= 1_000_000 (which means it's
      --  being
      --  represented as "1e+06" or +07 or +08, etc.), insert a decimal point
      --  after the 1 to make it conform to Ada floating point syntax.
      --
      --  NOTE: This is _very_ Glade-specific, depending on exactly how Glade
      --  represents large (> 1_000_000) numbers.  When it uses exponential
      --  notation, it always normalizes the number, ie., makes it a single
      --  digit followed by a decimal point, and correspondingly adjusts the
      --  exponent.  However, powers of 10 are not provided with a decimal
      --  point, so their string representation will start off with "1e" or
      --  "-1e".  Meaning that if the value is exponentiated, and the "1e"
      --  substring starts in the first or second character, it must be a power
      --  of ten.
      --  If that string is not present (such as in 2.3e+09) or does not start
      --  at index S'First or S'First + 1 (as in 1.1e+06), then it is a
      --  valid number as is.

      if Exponentiated then
         Mantissa_Start := Index (S, "1e");
         if Mantissa_Start not in S'First .. S'First + 1 then
            --  This is not a power of ten.
            return S;
         else
            return Replace_Slice
              (S, Mantissa_Start, Mantissa_Start + 1, "1.0e");
         end if;

      else
         if Index (S, ".") /= 0 then
            return S;
         else
            return S & ".0";
         end if;
      end if;
   end To_Float;

   -------------
   -- Gen_Set --
   -------------

   procedure Gen_Set
     (N             : Node_Ptr;
      Name          : String;
      File          : File_Type;
      Prefix        : String  := "";
      Postfix       : String  := "";
      Is_Float      : Boolean := False;
      Property_Name : String := "")
   is
      P   : Node_Ptr;
      Cur : constant String := Get_Attribute (Find_Tag_With_Attribute
         (N, "widget", "id"), "id");
      Top : constant String := Get_Attribute (Find_Tag_With_Attribute
         (Find_Top_Widget (N), "widget", "id"), "id");

   begin
      if Property_Name = "" then
         P  := Find_Tag_With_Attribute (N.Child, "property", "name", Name);
      else
         P  := Find_Tag_With_Attribute
           (N.Child, "property", "name", Property_Name);
      end if;

      if P /= null then
         Put (File, "   Set_" & To_Ada (Name) & " (");

         if Top /= Cur then
            Put (File, To_Ada (Top) & ".");
         end if;

         Put (File, To_Ada (Cur) & ", ");

         if Prefix /= "" then
            if Prefix (Prefix'Last) = '"' then
               --  If the value is text, adjust it before inserting it.
               Put_Line (File, Prefix & Adjust (P.Value.all) & Postfix & ");");

            else
               Put_Line (File, Prefix & P.Value.all & Postfix & ");");
            end if;
         else
            if Is_Float then
               Put_Line (File, To_Float (P.Value.all) & ");");
            else
               Put_Line (File, To_Ada (P.Value.all) & ");");
            end if;
         end if;
      end if;
   end Gen_Set;

   procedure Gen_Set
     (N : Node_Ptr; Name, Field : String; File : File_Type)
   is
      P   : constant Node_Ptr := Find_Tag_With_Attribute
         (N.Child, "property", "name", Field);
      Cur : constant String := Get_Attribute (Find_Tag_With_Attribute
         (N, "widget", "id"), "id");
      Top : constant String := Get_Attribute (Find_Tag_With_Attribute
         (Find_Top_Widget (N), "widget", "id"), "id");

   begin
      if P /= null then
         Put (File, "   Set_" & To_Ada (Name) & " (");

         if Cur /= Top then
            Put (File, To_Ada (Top) & ".");
         end if;

         Put_Line (File, To_Ada (Cur) & ", " &
           To_Ada (P.Value.all) & ");");
      end if;
   end Gen_Set;

   procedure Gen_Set
     (N : Node_Ptr;
      Name, Field1, Field2, Field3, Field4 : String;
      File : File_Type;
      Is_Float : Boolean := False)
   is
      P   : constant Node_Ptr := Find_Tag_With_Attribute
         (N.Child, "property", "name", Field1);
      Q   : constant Node_Ptr := Find_Tag_With_Attribute
         (N.Child, "property", "name", Field2);
      R   : constant Node_Ptr := Find_Tag_With_Attribute
         (N.Child, "property", "name", Field3);
      S   : constant Node_Ptr := Find_Tag_With_Attribute
         (N.Child, "property", "name", Field4);
      Cur : constant String := Get_Attribute (Find_Tag_With_Attribute
         (N, "widget", "id"), "id");
      Top : constant String := Get_Attribute (Find_Tag_With_Attribute
         (Find_Top_Widget (N), "widget", "id"), "id");

   begin
      if P /= null then
         if Field2 = "" then
            if Is_Float then
               Put (File, "   Set_" & Name & " (");

               if Cur /= Top then
                  Put (File, To_Ada (Top) & ".");
               end if;

               Put (File, To_Ada (Cur) & ", " &
                 To_Float (P.Value.all));
            else
               Put (File, "   Set_" & Name & " (");

               if Cur /= Top then
                  Put (File, To_Ada (Top) & ".");
               end if;

               Put (File, To_Ada (Cur) & ", " &
                 To_Ada (P.Value.all));
            end if;

         elsif Q = null then
            --  Field1 has been found, but not Field2. Abort.
            return;

         elsif (Field3 = "" or else R /= null)
           and then (Field4 = "" or else S /= null)
         then
            Put (File, "   Set_" & Name & " (");

            if Cur /= Top then
               Put (File, To_Ada (Top) & ".");
            end if;

            Put (File, To_Ada (Cur) & ", ");

            if Is_Float then
               Put (File, To_Float (P.Value.all) & ", " & To_Float
                  (Q.Value.all));

            elsif Q /= null then
               Put (File, To_Ada (P.Value.all) & ", " & To_Ada
                  (Q.Value.all));

            else
               --  ??? Need to find a clean and uniform way of handling default
               --  integer values

               Put (File, To_Ada (P.Value.all) & ", -1");
            end if;

            if Field3 /= "" and R /= null then
               if Is_Float then
                  Put (File, ", " & To_Float (R.Value.all));
               else
                  Put (File, ", " & To_Ada (R.Value.all));
               end if;

               if Field4 /= "" and S /= null then
                  if Is_Float then
                     Put (File, ", " & To_Float (S.Value.all));
                  else
                     Put (File, ", " & To_Ada (S.Value.all));
                  end if;
               end if;
            end if;
         end if;

         Put_Line (File, ");");
      end if;
   end Gen_Set;

   -------------
   -- Gen_New --
   -------------

   procedure Gen_New
     (N        : Node_Ptr;
      Class    : String;
      Param1, Param2, New_Name : String := "";
      File     : File_Type;
      Prefix   : String := "";
      Postfix  : String := "")
   is
      P   : constant String := Get_Attribute (N, "id");
      Cur : constant String := Get_Attribute (N, "id");
      Top : constant String := Get_Attribute (Find_Top_Widget (N), "id");
   begin
      if N.Specific_Data.Created then
         return;
      end if;

      if P /= "" then
         Add_Package (Class);

         if Param1 /= "" then
            if Cur = Top then
               Put (File, "   Gtk." & Class & ".Initialize");
            else
               Put (File, "   Gtk_New");
            end if;

            if New_Name /= "" then
               Put (File, '_' & New_Name);
            end if;

            Put (File, " (");
            if Cur /= Top then
               Put (File, To_Ada (Top) & ".");
            end if;

            Put (File, To_Ada (P) & ", ");

            if Prefix /= "" then
               if Prefix (Prefix'Last) = '"' then
                  Put (File, Prefix & Adjust (Param1) & Postfix);

               else
                  Put (File, Prefix & Param1 & Postfix);
               end if;
            else
               Put (File, To_Ada (Param1));
            end if;

            if Param2 /= "" then
               Put (File, ", " & To_Ada (Param2));
            end if;

            Put_Line (File, ");");

         else
            if Cur = Top then
               Put (File, "   Gtk." & Class & ".Initialize");
            else
               Put (File, "   Gtk_New");
            end if;

            if New_Name /= "" then
               Put (File, '_' & New_Name);
            end if;

            Put (File, " (");

            if Cur /= Top then
               Put (File, To_Ada (Top) & ".");
            end if;

            Put_Line (File, To_Ada (P) & ");");
         end if;

         N.Specific_Data.Created := True;
      end if;
   end Gen_New;

   procedure Gen_New
     (N        : Node_Ptr;
      Class, Param1, Param2, Param3, Param4, Param5 : String;
      File     : File_Type;
      Prefix   : String := "";
      Postfix  : String := "")
   is
      Top : constant String := Get_Name (Find_Top_Widget (N));
      Cur : constant String := Get_Name (N);
   begin
      if N.Specific_Data.Created then
         return;
      end if;

      if Cur /= "" then
         Add_Package (Class);

         if Cur = Top then
            Put (File, "   Gtk." & Class & ".Initialize");
         else
            Put_Line (File, "   Gtk_New");
         end if;

         Put (File, "     (");

         if Cur /= Top then
            Put (File, To_Ada (Top) & ".");
         end if;

         Put (File, To_Ada (Cur) & ", ");

         if Prefix /= "" then
            Put (File, Prefix & Param1 & Postfix);
         else
            Put (File, To_Ada (Param1));
         end if;

         Put (File, ", " & To_Ada (Param2));
         Put_Line (File, ", " & To_Ada (Param3) & ", ");
         Put (File, "      " & To_Ada (Param4));

         if Param5 /= "" then
            Put (File, ", " & To_Ada (Param5));
         end if;

         Put_Line (File, ");");
         N.Specific_Data.Created := True;
      end if;
   end Gen_New;

   ---------------
   -- Gen_Child --
   ---------------

   procedure Gen_Child (N, Child : Node_Ptr; File : File_Type) is
      P      : constant String_Ptr := Get_Field (N, "name");
      Top    : constant String_Ptr := Get_Field (Find_Top_Widget (N), "name");
      Parent : String_Ptr;

   begin
      if P /= null then
         Parent := Get_Field
           (Find_Parent (N.Parent, Get_Part (Child.Value.all, 1)).Parent,
            "name");

         Add_Package (To_Package_Name (Get_Field (N, "class").all));
         Put (File, "   " & To_Ada (Top.all) & "." & To_Ada (P.all) &
              " := Get_" & To_Ada (Get_Part (Child.Value.all, 2)) & " (");

         if Parent /= Top then
            Put (File, To_Ada (Top.all) & ".");
         end if;

         Put_Line (File, To_Ada (Parent.all) & ");");
      end if;
   end Gen_Child;

   --------------------
   -- Gen_Call_Child --
   --------------------

   procedure Gen_Call_Child
     (N, Child, Parent : Node_Ptr;
      Class, Call : String;
      Param1, Param2, Param3 : String := "";
      File : File_Type)
   is
      pragma Unreferenced (Class);
      P      : constant String := Get_Attribute (N, "id");
      Top    : constant String := Get_Attribute (Find_Top_Widget (N), "id");

   begin
      if P /= "" then
         if Child = null then
            Put (File, "   " & Call & " (");

            declare
               Parent_Str : constant String := Get_Attribute (Parent, "id");
            begin

               if Top /= Parent_Str then
                  Put (File, To_Ada (Top) & ".");
               end if;

               Put (File, To_Ada (Parent_Str) & ", " &
                    To_Ada (Top) & "." & To_Ada (P));
            end;
         end if;

         if Param1 /= "" then
            Put (File, ", " & To_Ada (Get_Field (Child, Param1).all));
         end if;

         if Param2 /= "" then
            Put (File, ", " & To_Ada (Get_Field (Child, Param2).all));
         end if;

         if Param3 /= "" then
            Put (File, ", " & To_Ada (Get_Field (Child, Param3).all));
         end if;

         Put_Line (File, ");");
      end if;
   end Gen_Call_Child;

   ------------------
   -- Gen_Packages --
   ------------------

   procedure Gen_Packages (File : File_Type) is
      S : String_Ptr;

   begin
      for J in Package_Range'First .. Num_Packages loop
         S := Packages (J);

         --  If the package is fully qualified (contains a dot), print it
         --  as is. Otherwise, assume it is a child of Gtk.

         if Index (S.all, ".") /= 0 then
            Put_Line (File, "with " & S.all & "; use " & S.all & ";");
         else
            Put_Line (File, "with Gtk." & S.all & "; use Gtk." & S.all & ";");
         end if;
      end loop;
   end Gen_Packages;

   --------------------
   -- Reset_Packages --
   --------------------

   procedure Reset_Packages is
   begin
      Num_Packages := 0;
   end Reset_Packages;

   ----------------
   -- Reset_Tree --
   ----------------

   procedure Reset_Tree (N : Node_Ptr; Check_Next : Boolean := True) is
      M : Node_Ptr;
   begin
      N.Specific_Data.Created := False;
      N.Specific_Data.Initialized := False;
      N.Specific_Data.Has_Container := False;
      N.Specific_Data.Has_Accel_Group := False;
      N.Specific_Data.Has_Radio_Group := False;

      if Check_Next then
         M := N.Next;

         while M /= null loop
            Reset_Tree (M, Check_Next => False);
            M := M.Next;
         end loop;
      end if;

      if N.Child /= null then
         Reset_Tree (N.Child);
      end if;
   end Reset_Tree;

   ----------------
   -- Gen_Signal --
   ----------------

   procedure Gen_Signal
     (N            : Node_Ptr;
      File         : File_Type;
      Widget_Class : String := "";
      The_Object   : String := "")
   is
      P        : Node_Ptr := Find_Tag (N.Child, "signal");
      Top      : constant Node_Ptr := Find_Top_Widget (N);
      Current  : constant String := Get_Name (N);

      Returned : GType;
      Rename   : String_Ptr;
      Q        : Signal_Query;

      function Simple_Class (Class : String) return String;
      --  Return the simple name of a class.
      --  This currently simply replaces Gtk[HV]* by Gtk*

      function Simple_Class (Class : String) return String is
      begin
         if Widget_Class = "" then
            return Get_Class (N);
         end if;

         if Class /= "" and then Class'Length >= 5
           and then Class (Class'First .. Class'First + 2) = "Gtk"
           and then
             (Class (Class'First + 3) = 'H'
              or else Class (Class'First + 3) = 'V')
           and then Class (Class'First + 4) in 'A' .. 'Z'
           and then Class (Class'First + 4 .. Class'Last) /= "Button_Box"
         then
            return "Gtk" & Class (Class'First + 4 .. Class'Last);
         else
            return Class;
         end if;
      end Simple_Class;

      Orig_Class : constant String := Simple_Class (Widget_Class);
      Class      : String_Ptr;

      function Yes_No_To_True_False (S : in String) return String;
      --  Transform "yes" to "True" and "no" to "False".
      --  By default return "False".

      function Yes_No_To_True_False (S : in String) return String is
      begin
         if S = "yes" then
            return "True";
         else
            return "False";
         end if;
      end Yes_No_To_True_False;

   begin
      while P /= null loop
         declare
            Handler  : constant String := Get_Attribute (P, "handler");
            Name     : constant String := Get_Attribute (P, "name");
            Object   : constant String := Get_Attribute (P, "object");
            After    : constant String :=
              Yes_No_To_True_False (Get_Attribute (P, "after"));
            Id       : Signal_Id := Lookup (Type_From_Name (Orig_Class), Name);
            Connect_To_Buffer : Boolean := False;

         begin
            if Id = Null_Signal_Id
              and then Orig_Class = "GtkTextView"
            then
               Id := Lookup (Type_From_Name ("GtkTextBuffer"), Name);
               Connect_To_Buffer := True;
               Class := new String'("GtkTextBuffer");

            else
               Class := new String'(Orig_Class); --  ??? fix when having obj
            end if;

            if Id = Invalid_Signal_Id
              or else Id = Null_Signal_Id
            then
               Put_Line ("   -- Signal " & Name & " invalid for "
                         & To_Ada (Current));
               Put_Line ("   !!!");

            else
               Query (Id, Q);
               Returned := Return_Type (Q);

               Rename := Add_Signal
                 (Top,
                  new String'(Handler),
                  new String'(Name),
                  Class,
                  new String'(Orig_Class));

               if Returned <= GType_None and then Class.all /= "GtkWidget" then
                  Add_Signal_Instantiation (Class, Rename);
               end if;

               if Returned > GType_None then
                  Put (File, "   Return_Callback.");
               else
                  Put
                    (File, "   " &
                     To_Ada
                       (Class (Class'First + 3 .. Class'Last)) & "_Callback.");
               end if;

               if Object /= "" then
                  Put (File, "Object_");
               end if;

               Put_Line (File, "Connect");
               Put (File, "     (");

               if The_Object = "" then
                  if Connect_To_Buffer then
                     Put (File, "Get_Buffer (");
                  end if;

                  if Top /= N then
                     Put (File, To_Ada (Get_Name (Top)) & ".");
                  end if;

                  Put (File, To_Ada (Current));

                  if Connect_To_Buffer then
                     Put (File, ")");
                  end if;
               else
                  Put (File, The_Object);
               end if;

               Put (File, ", """ & Name & """,");

               if Params (Q)'Length = 0 then
                  New_Line (File);
                  Put (File, "      " &
                       To_Ada (Class (Class'First + 3 .. Class'Last)) &
                       "_Callback.To_Marshaller (" & To_Ada (Handler)
                       & "'Access)");
               else
                  Put (File, " " & To_Ada (Handler) & "'Access");
               end if;

               if Object /= "" then
                  Put (File, ", " & To_Ada (Object));
               end if;

               if After /= "" then
                  Put (File, ", " & To_Ada (After));
               end if;

               Put_Line (File, ");");
            end if;
         end;

         P := Find_Tag (P.Next, "signal");
      end loop;
   end Gen_Signal;

   -------------------------------
   -- Gen_Signal_Instantiations --
   -------------------------------

   function Gen_Signal_Instantiations
     (Project : String; File : File_Type) return Natural
   is
      R, S     : String_Ptr;
      SR       : Signal_Rec;
      Prev_SR  : Signal_Rec;
      Kind     : String_Ptr;
      Returned : GType;
      Q        : Signal_Query;

   begin
      if Num_Signal_Instantiations > 0 then
         Put_Line (File, "with Gtk.Handlers;");
         Put_Line (File, "pragma Elaborate_All (Gtk.Handlers);");
      end if;

      for J in Signal_Range'First .. Num_Signal_Instantiations loop
         if Signal_Instantiations (J).Rename = null then
            S := new String'(To_Package_Name
              (Signal_Instantiations (J).Instantiation.all));
            Put_Line (File, "with " & S.all & "; use " & S.all & ";");
            Free (S);
         end if;
      end loop;

      New_Line (File);
      Put_Line (File, "package Callbacks_" & Project & " is");
      New_Line (File);

      for J in Signal_Range'First .. Num_Signal_Instantiations loop
         R := Signal_Instantiations (J).Rename;
         S := Signal_Instantiations (J).Instantiation;
         Put (File, "   package " &
           To_Ada (S (S'First + 3 .. S'Last)) & "_Callback ");

         if R = null then
            Put_Line (File, "is new");
            Put_Line (File, "     Gtk.Handlers.Callback (" &
              To_Ada (S.all) & "_Record);");

         else
            Put_Line (File, "renames " &
              To_Ada (R (R'First + 3 .. R'Last)) & "_Callback;");
         end if;

         New_Line (File);
      end loop;

      Put_Line (File, "end Callbacks_" & Project & ";");

      for J in Signal_Range'First .. Num_Signals loop
         SR := Signals (J);

         if Prev_SR.Widget = null or else SR.Widget /= Prev_SR.Widget then
            Prev_SR := SR;
            Put_Line (File, "with Gtk.Arguments;");
            Put_Line (File, "with Gtk.Widget; use Gtk.Widget;");
            New_Line (File);
            Put_Line (File, "package " &
              To_Ada (Get_Name (SR.Widget)) &
              "_Pkg.Callbacks is");

            for J in Signal_Range'First .. Num_Signals loop
               if Signals (J).Widget.all = SR.Widget.all then
                  Query (Lookup (Type_From_Name (Signals (J).Orig_Class.all),
                                 Signals (J).Signal.all),
                         Q);
                  Returned := Return_Type (Q);

                  if Returned > GType_None then
                     Put (File, "   function ");
                  else
                     Put (File, "   procedure ");
                  end if;

                  Put_Line (File, To_Ada (Signals (J).Handler.all));
                  Put (File, "     (Object : access ");

                  if Returned > GType_None then
                     Put (File, "Gtk_Widget");
                  else
                     Put (File, To_Ada (Signals (J).Class.all));
                  end if;

                  Put (File, "_Record'Class");

                  if Params (Q)'Length > 0 then
                     Put_Line (File, ";");
                     Put (File, "      Params : Gtk.Arguments.Gtk_Args)");
                  else
                     Put (File, ")");
                  end if;

                  if Returned > GType_None then
                     Put (File, " return Boolean");
                  end if;

                  Put_Line (File, ";");
                  New_Line (File);
               end if;
            end loop;

            Put_Line (File, "end " &
              To_Ada (Get_Name (SR.Widget)) & "_Pkg.Callbacks;");

            --  ??? Need to find a way to put only the required packages

            Put_Line (File, "with System; use System;");
            Put_Line (File, "with Glib; use Glib;");
            Put_Line (File, "with Gdk.Event; use Gdk.Event;");
            Put_Line (File, "with Gdk.Types; use Gdk.Types;");
            Put_Line (File, "with Gtk.Accel_Group; use Gtk.Accel_Group;");
            Put_Line (File, "with Gtk.Object; use Gtk.Object;");
            Put_Line (File, "with Gtk.Enums; use Gtk.Enums;");
            Put_Line (File, "with Gtk.Style; use Gtk.Style;");
            Put_Line (File, "with Gtk.Widget; use Gtk.Widget;");
            New_Line (File);
            Put_Line (File, "package body " &
              To_Ada (Get_Name (SR.Widget)) &
              "_Pkg.Callbacks is");
            New_Line (File);
            Put_Line (File, "   use Gtk.Arguments;");
            New_Line (File);

            for J in Signal_Range'First .. Num_Signals loop
               if Signals (J).Widget.all = SR.Widget.all then
                  declare
                     Handler : constant String :=
                       To_Ada (Signals (J).Handler.all);
                     Dashes : constant String (1 .. Handler'Length + 6) :=
                       (others => '-');

                  begin
                     Query (Lookup
                            (Type_From_Name (Signals (J).Orig_Class.all),
                             Signals (J).Signal.all),
                            Q);
                     Returned := Return_Type (Q);

                     Put_Line (File, "   " & Dashes);
                     Put_Line (File, "   -- " & Handler & " --");
                     Put_Line (File, "   " & Dashes);
                     New_Line (File);

                     if Returned > GType_None then
                        Put (File, "   function ");
                     else
                        Put (File, "   procedure ");
                     end if;

                     Put_Line (File, Handler);
                     Put (File, "     (Object : access ");

                     if Returned > GType_None then
                        Put (File, "Gtk_Widget");
                     else
                        Put (File, To_Ada (Signals (J).Class.all));
                     end if;

                     Put (File, "_Record'Class");

                     declare
                        P : constant GType_Array := Params (Q);
                     begin

                        if P'Length > 0 then
                           Put_Line (File, ";");
                           Put (File,
                                "      Params : Gtk.Arguments.Gtk_Args)");
                        else
                           Put (File, ")");
                        end if;

                        if Returned > GType_None then
                           Put (File, " return Boolean");
                        end if;

                        New_Line (File);
                        Put_Line (File, "   is");

                        for K in P'Range loop
                           Kind := new String'(To_Ada (Type_Name (P (K))));

                           if Kind.all = "Gpointer" then
                              Free (Kind);
                              Kind := new String'("Address");

                           elsif Kind.all = "Gtk_String" then
                              Free (Kind);
                              Kind := new String'("String");
                           end if;

                           if Kind.all = "Gchararray" then
                              Put (File, "      Arg" &
                                   Trim (Guint'Image (K - P'First + 1), Left) &
                                   " : UTF8_String := ");
                           else
                              Put (File, "      Arg" &
                                   Trim (Guint'Image (K - P'First + 1), Left) &
                                   " : " & Kind.all & " := ");
                           end if;

                           --  ??? This whole section is ugly. Need to find a
                           --  cleaner and more automated way of generating the
                           --  right code.

                           if Kind.all = "Gdk_Event" then
                              Put (File, "To_Event");
                           elsif Kind (Kind'First .. Kind'First + 2)
                             = "Gtk"
                           then
                              if Kind.all = "Gtk_Clist_Row"
                                or else Kind.all = "Gtk_Ctree_Node"
                                or else Kind.all = "Gtk_Accel_Group"
                                or else Kind.all = "Gtk_Style"
                              then
                                 Put (File, Kind.all & " (To_C_Proxy");
                              elsif Kind.all = "Gtk_Object"
                                or else Kind.all = "Gtk_Widget"
                              then
                                 Put (File, Kind.all & " (To_Object");
                              else
                                 Put (File, Kind.all & "'Val (To_Gint");
                              end if;

                           elsif Kind (Kind'First .. Kind'First + 2)
                             = "Gdk"
                           then
                              Put (File, Kind.all & " (To_Gint");
                           elsif Kind.all = "Gchararray" then
                              Put (File, "To_String");
                           else
                              Put (File, "To_" & Kind.all);
                           end if;

                           Put (File, " (Params, " &
                                Trim (Guint'Image (K - P'First + 1), Left));

                           if Kind (Kind'First .. Kind'First + 2) = "Gtk"
                             or else Kind (Kind'First .. Kind'First + 2) =
                             "Gdk"
                           then
                              if Kind.all = "Gdk_Event" then
                                 Put_Line (File, ");");
                              else
                                 Put_Line (File, "));");
                              end if;
                           else
                              Put_Line (File, ");");
                           end if;

                           Free (Kind);
                        end loop;
                     end;

                     Put_Line (File, "   begin");

                     if Returned > GType_None then
                        Put_Line (File, "      return False;");
                     else
                        Put_Line (File, "      null;");
                     end if;

                     Put_Line (File, "   end " & Handler & ";");
                     New_Line (File);
                  end;
               end if;
            end loop;

            Put_Line (File, "end " &
              To_Ada (Get_Name (SR.Widget)) &
              "_Pkg.Callbacks;");
         end if;
      end loop;

      return Num_Signal_Instantiations;
   end Gen_Signal_Instantiations;

   ---------------------
   -- Gettext_Support --
   ---------------------

   function Gettext_Support (N : Node_Ptr) return Boolean is
      P : Node_Ptr;
   begin
      if N /= null then
         P := Find_Tag_With_Attribute (N.Child, "property",
               "translatable");
         if N /= null then
            declare
               S : constant String := Get_Attribute (P, "translatable");
            begin
               return S = "yes";
            end;
         end if;
      end if;

      return False;
   end Gettext_Support;

   ---------------------
   -- To_Package_Name --
   ---------------------

   --  The following table is needed to transform Gtk+ names that cannot
   --  be mapped automatically (e.g Ada reserved words) into the correct GtkAda
   --  package name.

   type Package_Mapping is record
      Gtk_Name, GtkAda_Package : String_Ptr;
   end record;

   type Special_Packages_Type is array (Positive range <>) of Package_Mapping;

   Special_Packages : constant Special_Packages_Type :=
     ((new String '("GtkRange"),      new String '("Gtk.GRange")),
      (new String '("GtkEntry"),      new String '("Gtk.GEntry")),
      (new String '("GtkCTree"),      new String '("Gtk.Ctree")),
      (new String '("GtkCList"),      new String '("Gtk.Clist")),
      (new String '("GtkHScale"),     new String '("Gtk.Scale")),
      (new String '("GtkVScale"),     new String '("Gtk.Scale")),
      (new String '("GtkHBox"),       new String '("Gtk.Box")),
      (new String '("GtkVBox"),       new String '("Gtk.Box")),
      (new String '("GtkHPaned"),     new String '("Gtk.Paned")),
      (new String '("GtkVPaned"),     new String '("Gtk.Paned")),
      (new String '("GtkHRuler"),     new String '("Gtk.Ruler")),
      (new String '("GtkVRuler"),     new String '("Gtk.Ruler")),
      (new String '("GtkHScrollbar"), new String '("Gtk.Scrollbar")),
      (new String '("GtkVScrollbar"), new String '("Gtk.Scrollbar")),
      (new String '("GtkHSeparator"), new String '("Gtk.Separator")),
      (new String '("GtkVSeparator"), new String '("Gtk.Separator")));

   function To_Package_Name (S : String) return String is
   begin
      for J in Special_Packages'Range loop
         if S = Special_Packages (J).Gtk_Name.all then
            return Special_Packages (J).GtkAda_Package.all;
         end if;
      end loop;

      --  No fix up needed

      return "Gtk." & To_Ada (S (S'First + 3 .. S'Last));
   end To_Package_Name;

   ------------------
   -- Get_Property --
   ------------------

   function Get_Property
     (N        : Node_Ptr;
      Property : String) return String_Ptr
   is
      C : Node_Ptr;
   begin
      if N = null then
         return null;
      end if;

      C := N.Child;

      while C /= null loop
         if C.Tag.all = "property"
           and then Get_Attribute (C, "name") = Property
         then
            return C.Value;
         end if;

         C := C.Next;
      end loop;

      return null;
   end Get_Property;

   function Get_Property
     (N        : Node_Ptr;
      Property : String;
      Default  : String := "") return String
   is
      P : constant String_Ptr := Get_Property (N, Property);
   begin
      if P = null then
         return Default;
      else
         return P.all;
      end if;
   end Get_Property;

   ---------------
   -- Get_Class --
   ---------------

   function Get_Class (N : Node_Ptr) return String is
   begin
      if N = null then
         return "";
      end if;

      if N.Tag.all = "widget" then
         return Get_Attribute (N, "class");
      end if;

      return "";
   end Get_Class;

   ---------------
   -- Get_Name  --
   ---------------

   function Get_Name (N : Node_Ptr) return String is
   begin
      if N = null then
         return "";
      end if;

      return Get_Attribute (N, "id");
   end Get_Name;

end Glib.Glade;
