------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2017, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with FE310_SVD.UART; use FE310_SVD.UART;
with Interfaces;     use Interfaces;

----------------
-- FE310.UART --
----------------

package body FE310.UART is

   -------------------
   -- Set_Stop_Bits --
   -------------------

   procedure Set_Stop_Bits (This : in out UART_Port; To : Stop_Bits) is
   begin
      This.Periph.TXCTRL.NSTOP := (case To is
                                      when Stopbits_1 => False,
                                      when Stopbits_2 => True);
   end Set_Stop_Bits;

   -------------------
   -- Set_Baud_Rate --
   -------------------

   procedure Set_Baud_Rate (This : in out UART_Port;  To : Baud_Rates) is
   begin
      This.Periph.DIV.DIV := UInt16 (CPU_Frequency / (To - 1));
   end Set_Baud_Rate;

   ---------------
   -- Enable_RX --
   ---------------

   procedure Enable_RX (This : in out UART_Port) is
   begin
      This.Periph.RXCTRL.ENABLE := True;
   end Enable_RX;

   ---------------
   -- Enable_TX --
   ---------------

   procedure Enable_TX (This : in out UART_Port) is
   begin
      This.Periph.TXCTRL.ENABLE := True;
   end Enable_TX;

   ----------------
   -- Disable_RX --
   ----------------

   procedure Disable_RX (This : in out UART_Port) is
   begin
      This.Periph.RXCTRL.ENABLE := False;
   end Disable_RX;

   ----------------
   -- Disable_TX --
   ----------------

   procedure Disable_TX (This : in out UART_Port) is
   begin
      This.Periph.TXCTRL.ENABLE := False;
   end Disable_TX;

   --------------------------
   -- RX_Interrupt_Pending --
   --------------------------

   function RX_Interrupt_Pending (This : UART_Port) return Boolean
     is (This.Periph.IP.RXWM);

   --------------------------
   -- TX_Interrupt_Pending --
   --------------------------

   function TX_Interrupt_Pending (This : UART_Port) return Boolean
     is (This.Periph.IP.TXWM);

   -------------------------
   -- Enable_RX_Interrupt --
   -------------------------

   procedure Enable_RX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.RXWM := True;
   end Enable_RX_Interrupt;

   -------------------------
   -- Enable_TX_Interrupt --
   -------------------------

   procedure Enable_TX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.TXWM := True;
   end Enable_TX_Interrupt;

   --------------------------
   -- Disable_RX_Interrupt --
   --------------------------

   procedure Disable_RX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.RXWM := False;
   end Disable_RX_Interrupt;

   --------------------------
   -- Disable_TX_Interrupt --
   --------------------------

   procedure Disable_TX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.TXWM := False;
   end Disable_TX_Interrupt;

   ------------------------------
   -- Set_Interrupt_Thresholds --
   ------------------------------

   procedure Set_Interrupt_Thresholds (This   : in out UART_Port;
                                       RX, TX : UInt3)
   is
   begin
      This.Periph.TXCTRL.TXCNT := TX;
      This.Periph.RXCTRL.RXCNT := RX;
   end Set_Interrupt_Thresholds;

   --------------
   -- Transmit --
   --------------

   overriding
   procedure Transmit
     (This    : in out UART_Port;
      Data    : UART_Data_8b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
   begin
      for Elt of Data loop
         while This.Periph.TXDATA.FULL loop
            null;
         end loop;

         This.Periph.TXDATA.DATA := Elt;
      end loop;
      Status := Ok;
   end Transmit;

   --------------
   -- Transmit --
   --------------

   overriding
   procedure Transmit
     (This    : in out UART_Port;
      Data    : UART_Data_9b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
   begin
      raise Program_Error with "FE310 UART only support 8bit mode";
   end Transmit;

   -------------
   -- Receive --
   -------------

   overriding
   procedure Receive
     (This    : in out UART_Port;
      Data    : out UART_Data_8b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
      Data_Reg : RXDATA_Register;
   begin
      for Elt of Data loop
         loop
            Data_Reg := This.Periph.RXDATA;
            exit when not Data_Reg.EMPTY;
         end loop;
         Elt := Data_Reg.DATA;
      end loop;
      Status := Ok;
   end Receive;

   -------------
   -- Receive --
   -------------

   overriding
   procedure Receive
     (This    : in out UART_Port;
      Data    : out UART_Data_9b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
   begin
      raise Program_Error with "FE310 UART only support 8bit mode";
   end Receive;

end FE310.UART;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 2017, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of the copyright holder nor the names of its     --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

with FE310_SVD.UART; use FE310_SVD.UART;

----------------
-- FE310.UART --
----------------

package body FE310.UART is

   -------------------
   -- Set_Stop_Bits --
   -------------------

   procedure Set_Stop_Bits (This : in out UART_Port; To : Stop_Bits) is
   begin
      This.Periph.TXCTRL.NSTOP := (case To is
                                      when Stopbits_1 => False,
                                      when Stopbits_2 => True);
   end Set_Stop_Bits;

   -------------------
   -- Set_Baud_Rate --
   -------------------

   procedure Set_Baud_Rate (This : in out UART_Port;  To : Baud_Rates) is
   begin
      This.Periph.DIV.DIV := UInt16 (CPU_Frequency / (To - 1));
   end Set_Baud_Rate;

   ---------------
   -- Enable_RX --
   ---------------

   procedure Enable_RX (This : in out UART_Port) is
   begin
      This.Periph.RXCTRL.ENABLE := True;
   end Enable_RX;

   ---------------
   -- Enable_TX --
   ---------------

   procedure Enable_TX (This : in out UART_Port) is
   begin
      This.Periph.TXCTRL.ENABLE := True;
   end Enable_TX;

   ----------------
   -- Disable_RX --
   ----------------

   procedure Disable_RX (This : in out UART_Port) is
   begin
      This.Periph.RXCTRL.ENABLE := False;
   end Disable_RX;

   ----------------
   -- Disable_TX --
   ----------------

   procedure Disable_TX (This : in out UART_Port) is
   begin
      This.Periph.TXCTRL.ENABLE := False;
   end Disable_TX;

   --------------------------
   -- RX_Interrupt_Pending --
   --------------------------

   function RX_Interrupt_Pending (This : UART_Port) return Boolean
     is (This.Periph.IP.RXWM);

   --------------------------
   -- TX_Interrupt_Pending --
   --------------------------

   function TX_Interrupt_Pending (This : UART_Port) return Boolean
     is (This.Periph.IP.TXWM);

   -------------------------
   -- Enable_RX_Interrupt --
   -------------------------

   procedure Enable_RX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.RXWM := True;
   end Enable_RX_Interrupt;

   -------------------------
   -- Enable_TX_Interrupt --
   -------------------------

   procedure Enable_TX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.TXWM := True;
   end Enable_TX_Interrupt;

   --------------------------
   -- Disable_RX_Interrupt --
   --------------------------

   procedure Disable_RX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.RXWM := False;
   end Disable_RX_Interrupt;

   --------------------------
   -- Disable_TX_Interrupt --
   --------------------------

   procedure Disable_TX_Interrupt (This : in out UART_Port) is
   begin
      This.Periph.IE.TXWM := False;
   end Disable_TX_Interrupt;

   ------------------------------
   -- Set_Interrupt_Thresholds --
   ------------------------------

   procedure Set_Interrupt_Thresholds (This   : in out UART_Port;
                                       RX, TX : UInt3)
   is
   begin
      This.Periph.TXCTRL.TXCNT := TX;
      This.Periph.RXCTRL.RXCNT := RX;
   end Set_Interrupt_Thresholds;

   --------------
   -- Transmit --
   --------------

   overriding
   procedure Transmit
     (This    : in out UART_Port;
      Data    : UART_Data_8b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
   begin
      for Elt of Data loop
         while This.Periph.TXDATA.FULL loop
            null;
         end loop;

         This.Periph.TXDATA.DATA := Elt;
      end loop;
      Status := Ok;
   end Transmit;

   --------------
   -- Transmit --
   --------------

   overriding
   procedure Transmit
     (This    : in out UART_Port;
      Data    : UART_Data_9b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
   begin
      raise Program_Error with "FE310 UART only support 8bit mode";
   end Transmit;

   -------------
   -- Receive --
   -------------

   overriding
   procedure Receive
     (This    : in out UART_Port;
      Data    : out UART_Data_8b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
      pragma Unreferenced (Timeout);
      Data_Reg : RXDATA_Register;
   begin
      for Elt of Data loop
         loop
            Data_Reg := This.Periph.RXDATA;
            exit when not Data_Reg.EMPTY;
         end loop;
         Elt := Data_Reg.DATA;
      end loop;
      Status := Ok;
   end Receive;

   -------------
   -- Receive --
   -------------

   overriding
   procedure Receive
     (This    : in out UART_Port;
      Data    : out UART_Data_9b;
      Status  : out UART_Status;
      Timeout : Natural := 1000)
   is
   begin
      raise Program_Error with "FE310 UART only support 8bit mode";
   end Receive;

end FE310.UART;

Fix compile error

FE310.UART: Fix compile error


-----------------------------------------------------------------------
--  awa-users-beans -- ASF Beans for user module
--  Copyright (C) 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with ASF.Sessions;
with ASF.Events.Actions;
with ASF.Contexts.Faces;

with AWA.Users.Principals;
package body AWA.Users.Beans is

   use AWA.Users.Model;

   --  Action to register a user
   procedure Register_User (Data    : in out Authenticate_Bean;
                            Outcome : in out Unbounded_String) is
      User  : User_Ref;
      Email : Email_Ref;
   begin
      Email.Set_Email (Data.Email);
      User.Set_First_Name (Data.First_Name);
      User.Set_Last_Name (Data.Last_Name);
      User.Set_Password (Data.Password);
      Data.Manager.Create_User (User  => User,
                                Email => Email);
      Outcome := To_Unbounded_String ("success");
   end Register_User;

   --  Action to verify the user after the registration
   procedure Verify_User (Data    : in out Authenticate_Bean;
                          Outcome : in out Unbounded_String) is
      User    : User_Ref;
      Session : Session_Ref;
   begin
      Data.Manager.Verify_User (Key     => To_String (Data.Access_Key),
                                User    => User,
                                IpAddr  => "",
                                Session => Session);

      Outcome := To_Unbounded_String ("success");
   end Verify_User;

   --  Action to trigger the lost password email process.
   procedure Lost_Password (Data    : in out Authenticate_Bean;
                            Outcome : in out Unbounded_String) is
   begin
      Data.Manager.Lost_Password (Email => To_String (Data.Email));
      Outcome := To_Unbounded_String ("success");
   end Lost_Password;

   --  Action to validate the reset password key and set a new password.
   procedure Reset_Password (Data    : in out Authenticate_Bean;
                             Outcome : in out Unbounded_String) is
      User    : User_Ref;
      Session : Session_Ref;
   begin
      Data.Manager.Reset_Password (Key      => To_String (Data.Access_Key),
                                   Password => To_String (Data.Password),
                                   IpAddr   => "",
                                   User     => User,
                                   Session  => Session);
      Outcome := To_Unbounded_String ("success");
   end Reset_Password;

   procedure Set_Session_Principal (Data : in Authenticate_Bean;
                                    User : in AWA.Users.Model.User_Ref) is
      Principal : AWA.Users.Principals.Principal_Access := AWA.Users.Principals.Create (User);
      Ctx       : ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      Session   : ASF.Sessions.Session := Ctx.Get_Session (Create => True);
      Name      : constant String := "User: " & User.Get_Name;
   begin
      Session.Set_Principal (Principal.all'Access);
      Session.Set_Attribute (Name  => "user",
                             Value => Util.Beans.Objects.To_Object (Name));
   end Set_Session_Principal;

   --  Action to authenticate a user.
   procedure Authenticate_User (Data    : in out Authenticate_Bean;
                                Outcome : in out Unbounded_String) is
      User      : User_Ref;
      Session   : Session_Ref;
   begin
      Data.Manager.Authenticate (Email    => To_String (Data.Email),
                                 Password => To_String (Data.Password),
                                 IpAddr   => "",
                                 User     => User,
                                 Session  => Session);
      Outcome := To_Unbounded_String ("success");

      Data.Set_Session_Principal (User);
   end Authenticate_User;

   --  Create an authenticate bean.
   function Create_Authenticate_Bean (Module : in AWA.Users.Module.User_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : Authenticate_Bean_Access := new Authenticate_Bean;
   begin
      Object.Module := Module;
      Object.Manager := AWA.Users.Logic.Create_User_Manager (Module);
      return Object.all'Access;
   end Create_Authenticate_Bean;

   --  The code below this line could be generated automatically by an Asis tool.

   package Authenticate_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Authenticate_User,
                                                Name   => "authenticate");

   package Register_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Register_User,
                                                Name   => "register");

   package Verify_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Verify_User,
                                                Name   => "verify");

   package Lost_Password_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Lost_Password,
                                                Name   => "lostPassword");

   package Reset_Password_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Reset_Password,
                                                Name   => "resetPassword");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Authenticate_Binding.Proxy'Unchecked_Access,
         Register_Binding.Proxy'Unchecked_Access,
         Verify_Binding.Proxy'Unchecked_Access,
         Lost_Password_Binding.Proxy'Unchecked_Access,
         Reset_Password_Binding.Proxy'Unchecked_Access);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Authenticate_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "email" then
         return Util.Beans.Objects.To_Object (From.Email);
      elsif Name = "password" then
         return Util.Beans.Objects.To_Object (From.Password);
      elsif Name = "key" then
         return Util.Beans.Objects.To_Object (From.Access_Key);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Authenticate_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "email" then
         From.Email := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "password" then
         From.Password := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "key" then
         From.Access_Key := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Authenticate_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
   begin
      return Binding_Array'Unchecked_Access;
   end Get_Method_Bindings;

end AWA.Users.Beans;

-----------------------------------------------------------------------
--  awa-users-beans -- ASF Beans for user module
--  Copyright (C) 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with ASF.Sessions;
with ASF.Events.Actions;
with ASF.Contexts.Faces;

with AWA.Users.Principals;
package body AWA.Users.Beans is

   use AWA.Users.Model;

   --  Action to register a user
   procedure Register_User (Data    : in out Authenticate_Bean;
                            Outcome : in out Unbounded_String) is
      User  : User_Ref;
      Email : Email_Ref;
   begin
      Email.Set_Email (Data.Email);
      User.Set_First_Name (Data.First_Name);
      User.Set_Last_Name (Data.Last_Name);
      User.Set_Password (Data.Password);
      Data.Manager.Create_User (User  => User,
                                Email => Email);
      Outcome := To_Unbounded_String ("success");
   end Register_User;

   --  Action to verify the user after the registration
   procedure Verify_User (Data    : in out Authenticate_Bean;
                          Outcome : in out Unbounded_String) is
      User    : User_Ref;
      Session : Session_Ref;
   begin
      Data.Manager.Verify_User (Key     => To_String (Data.Access_Key),
                                User    => User,
                                IpAddr  => "",
                                Session => Session);

      Outcome := To_Unbounded_String ("success");
   end Verify_User;

   --  Action to trigger the lost password email process.
   procedure Lost_Password (Data    : in out Authenticate_Bean;
                            Outcome : in out Unbounded_String) is
   begin
      Data.Manager.Lost_Password (Email => To_String (Data.Email));
      Outcome := To_Unbounded_String ("success");
   end Lost_Password;

   --  Action to validate the reset password key and set a new password.
   procedure Reset_Password (Data    : in out Authenticate_Bean;
                             Outcome : in out Unbounded_String) is
      User    : User_Ref;
      Session : Session_Ref;
   begin
      Data.Manager.Reset_Password (Key      => To_String (Data.Access_Key),
                                   Password => To_String (Data.Password),
                                   IpAddr   => "",
                                   User     => User,
                                   Session  => Session);
      Outcome := To_Unbounded_String ("success");
   end Reset_Password;

   procedure Set_Session_Principal (Data : in Authenticate_Bean;
                                    User : in AWA.Users.Model.User_Ref) is
      Principal : AWA.Users.Principals.Principal_Access := AWA.Users.Principals.Create (User);
      Ctx       : ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      Session   : ASF.Sessions.Session := Ctx.Get_Session (Create => True);
      Name      : constant String := "User: " & User.Get_Name;
   begin
      Session.Set_Principal (Principal.all'Access);
      Session.Set_Attribute (Name  => "user",
                             Value => Util.Beans.Objects.To_Object (Name));
   end Set_Session_Principal;

   --  Action to authenticate a user.
   procedure Authenticate_User (Data    : in out Authenticate_Bean;
                                Outcome : in out Unbounded_String) is
      User      : User_Ref;
      Session   : Session_Ref;
   begin
      Data.Manager.Authenticate (Email    => To_String (Data.Email),
                                 Password => To_String (Data.Password),
                                 IpAddr   => "",
                                 User     => User,
                                 Session  => Session);
      Outcome := To_Unbounded_String ("success");

      Data.Set_Session_Principal (User);
   end Authenticate_User;

   --  Create an authenticate bean.
   function Create_Authenticate_Bean (Module : in AWA.Users.Module.User_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : Authenticate_Bean_Access := new Authenticate_Bean;
   begin
      Object.Module := Module;
      Object.Manager := AWA.Users.Logic.Create_User_Manager (Module);
      return Object.all'Access;
   end Create_Authenticate_Bean;

   --  The code below this line could be generated automatically by an Asis tool.

   package Authenticate_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Authenticate_User,
                                                Name   => "authenticate");

   package Register_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Register_User,
                                                Name   => "register");

   package Verify_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Verify_User,
                                                Name   => "verify");

   package Lost_Password_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Lost_Password,
                                                Name   => "lostPassword");

   package Reset_Password_Binding is
     new ASF.Events.Actions.Action_Method.Bind (Bean   => Authenticate_Bean,
                                                Method => Reset_Password,
                                                Name   => "resetPassword");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Authenticate_Binding.Proxy'Access,
         Register_Binding.Proxy'Access,
         Verify_Binding.Proxy'Access,
         Lost_Password_Binding.Proxy'Access,
         Reset_Password_Binding.Proxy'Access);

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Authenticate_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "email" then
         return Util.Beans.Objects.To_Object (From.Email);
      elsif Name = "password" then
         return Util.Beans.Objects.To_Object (From.Password);
      elsif Name = "key" then
         return Util.Beans.Objects.To_Object (From.Access_Key);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Authenticate_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "email" then
         From.Email := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "password" then
         From.Password := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "key" then
         From.Access_Key := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Authenticate_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end AWA.Users.Beans;

Replace Unchecked_Access by Access since the objects are declared at package level scope


-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Text_IO;

with Util.Log.Loggers;
with MAT.Frames.Print;
package body MAT.Frames is

   use type MAT.Types.Target_Addr;

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Frames.Targets");

   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   function Check (Frame : in Frame_Type) return Boolean is
      Parent : Frame_Type;
      Child  : Frame_Type;
      Result : Boolean := True;
   begin
      if Frame = null then
         return False;
      end if;
      Child := Frame.Children;
      while Child /= null loop
         if Child.Parent /= Frame then
            Log.Error ("Invalid parent link");
            Result := False;
         end if;
         if Child.Children /= null and then not Check (Child) then
            Log.Error ("A child is now invalid");
            Result := False;
         end if;
         Child := Child.Next;
      end loop;
      return Result;
   end Check;

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Get the root frame object.
   --  ------------------------------
   function Get_Root (Frame : in Frame_Type) return Frame_Type is
      Parent : Frame_Type := Frame;
   begin
      loop
         if Parent.Parent = null then
            return Parent;
         end if;
         Parent := Parent.Parent;
      end loop;
   end Get_Root;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   --  ------------------------------
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table is
      Length  : Natural;
   begin
      if Max_Level > 0 and Max_Level < Frame.Depth then
         Length := Max_Level;
      else
         Length := Frame.Depth;
      end if;
      declare
         Current : Frame_Type := Frame;
         Pos     : Natural    := Length;
         New_Pos : Natural;
         Pc      : Frame_Table (1 .. Length);
      begin
         while Current /= null and Pos /= 0 loop
            if Pos >= Current.Local_Depth then
               New_Pos := Pos - Current.Local_Depth + 1;
               Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
               Pos     := New_Pos - 1;
            else
               Pc (1 .. Pos) := Current.Calls (Current.Local_Depth - Pos - 1 .. Current.Local_Depth);
               Pos := 0;
            end if;
            Current := Current.Parent;
         end loop;
         return Pc;
      end;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and then F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
--                 Log.Error ("Frame is not linked to the correct parent");
--                 if not Check (Get_Root (Frame)) then
--                    Log.Error ("Check failed");
--                 else
--                    Log.Error ("Check is ok");
--                 end if;
--                 MAT.Frames.Print (Ada.Text_IO.Standard_Output, Get_Root (Frame));
               return;
            else
               F.Next := Frame.Next;
            end if;
         end if;
      end if;
--        Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
      if not Check (Get_Root (Frame)) then
         Log.Error ("Frame is invalid");
      end if;
   end Release;

   --  ------------------------------
   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   --  ------------------------------
   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : constant Frame_Type := new Frame '(Parent      => F.Parent,
                                                      Next        => F.Next,
                                                      Children    => F,
                                                      Used        => F.Used - 1,
                                                      Depth       => F.Depth,
                                                      Local_Depth => Pos,
                                                      Calls       => (others => 0));
      Child : Frame_Type := F.Parent.Children;
   begin
      Log.Debug ("Split frame");

      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      F.Used           := F.Used - 1;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
      if not Check (Get_Root (F)) then
         Log.Error ("Error when splitting frame");
      end if;
   end Split;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
         if not Check (Get_Root (Child)) then
            Log.Error ("Error when adding frame");
         end if;
      end loop;
      Result := Child;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Current : Frame_Type := Frame;
      Child   : Frame_Type;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : MAT.Types.Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               Current.Used := Current.Used + 1;
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Current.Used := Current.Used + 1;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current.Used := Current.Used + 1;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type is
      Child : Frame_Type := Frame;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural) is
      Current : Frame_Type := Frame;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search :
      while Pos <= Pc'Last loop
         declare
            Addr  : constant MAT.Types.Target_Addr := Pc (Pos);
            Child : Frame_Type  := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

-----------------------------------------------------------------------
--  mat-frames - Representation of stack frames
--  Copyright (C) 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Text_IO;

with Util.Log.Loggers;
with MAT.Frames.Print;
package body MAT.Frames is

   use type MAT.Types.Target_Addr;

   procedure Free is
     new Ada.Unchecked_Deallocation (Frame, Frame_Type);

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Frames.Targets");

   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive);

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type);

   function Check (Frame : in Frame_Type) return Boolean is
      Parent : Frame_Type;
      Child  : Frame_Type;
      Result : Boolean := True;
   begin
      if Frame = null then
         return False;
      end if;
      Child := Frame.Children;
      while Child /= null loop
         if Child.Parent /= Frame then
            Log.Error ("Invalid parent link");
            Result := False;
         end if;
         if Child.Children /= null and then not Check (Child) then
            Log.Error ("A child is now invalid");
            Result := False;
         end if;
         Child := Child.Next;
      end loop;
      return Result;
   end Check;

   --  ------------------------------
   --  Return the parent frame.
   --  ------------------------------
   function Parent (Frame : in Frame_Type) return Frame_Type is
   begin
      if Frame = null then
         return null;
      else
         return Frame.Parent;
      end if;
   end Parent;

   --  ------------------------------
   --  Get the root frame object.
   --  ------------------------------
   function Get_Root (Frame : in Frame_Type) return Frame_Type is
      Parent : Frame_Type := Frame;
   begin
      loop
         if Parent.Parent = null then
            return Parent;
         end if;
         Parent := Parent.Parent;
      end loop;
   end Get_Root;

   --  ------------------------------
   --  Returns the backtrace of the current frame (up to the root).
   --  When <tt>Max_Level</tt> is positive, limit the number of PC frames to the value.
   --  ------------------------------
   function Backtrace (Frame     : in Frame_Type;
                       Max_Level : in Natural := 0) return Frame_Table is
      Length  : Natural;
   begin
      if Max_Level > 0 and Max_Level < Frame.Depth then
         Length := Max_Level;
      else
         Length := Frame.Depth;
      end if;
      declare
         Current : Frame_Type := Frame;
         Pos     : Natural    := Length;
         New_Pos : Natural;
         Pc      : Frame_Table (1 .. Length);
      begin
         while Current /= null and Pos /= 0 loop
            if Pos >= Current.Local_Depth then
               New_Pos := Pos - Current.Local_Depth + 1;
               Pc (New_Pos .. Pos) := Current.Calls (1 .. Current.Local_Depth);
               Pos     := New_Pos - 1;
            else
               Pc (1 .. Pos) := Current.Calls (Current.Local_Depth - Pos + 1 .. Current.Local_Depth);
               Pos := 0;
            end if;
            Current := Current.Parent;
         end loop;
         return Pc;
      end;
   end Backtrace;

   --  ------------------------------
   --  Returns the number of children in the frame.
   --  When recursive is true, compute in the sub-tree.
   --  ------------------------------
   function Count_Children (Frame     : in Frame_Type;
                            Recursive : in Boolean := False) return Natural is
      Count : Natural := 0;
      Child : Frame_Type;
   begin
      if Frame /= null then
         Child := Frame.Children;
         while Child /= null loop
            Count := Count + 1;
            if Recursive then
               declare
                  N : Natural := Count_Children (Child, True);
               begin
                  if N > 0 then
                     N := N - 1;
                  end if;
                  Count := Count + N;
               end;
            end if;
            Child := Child.Next;
         end loop;
      end if;
      return Count;
   end Count_Children;

   --  ------------------------------
   --  Returns all the direct calls made by the current frame.
   --  ------------------------------
   function Calls (Frame : in Frame_Type) return Frame_Table is
      Nb_Calls : constant Natural   := Count_Children (Frame);
      Pc       : Frame_Table (1 .. Nb_Calls);
   begin
      if Frame /= null then
         declare
            Child : Frame_Type := Frame.Children;
            Pos   : Natural   := 1;
         begin
            while Child /= null loop
               Pc (Pos) := Child.Calls (1);
               Pos   := Pos + 1;
               Child := Child.Next;
            end loop;
         end;
      end if;
      return Pc;
   end Calls;

   --  ------------------------------
   --  Returns the current stack depth (# of calls from the root
   --  to reach the frame).
   --  ------------------------------
   function Current_Depth (Frame : in Frame_Type) return Natural is
   begin
      if Frame = null then
         return 0;
      else
         return Frame.Depth;
      end if;
   end Current_Depth;

   --  ------------------------------
   --  Create a root for stack frame representation.
   --  ------------------------------
   function Create_Root return Frame_Type is
   begin
      return new Frame;
   end Create_Root;

   --  ------------------------------
   --  Destroy the frame tree recursively.
   --  ------------------------------
   procedure Destroy (Frame : in out Frame_Type) is
      F : Frame_Type;
   begin
      if Frame = null then
         return;
      end if;
      --  Destroy its children recursively.
      while Frame.Children /= null loop
         F := Frame.Children;
         Destroy (F);
      end loop;

      --  Unlink from parent list.
      if Frame.Parent /= null then
         F := Frame.Parent.Children;
         if F = Frame then
            Frame.Parent.Children := Frame.Next;
         else
            while F /= null and then F.Next /= Frame loop
               F := F.Next;
            end loop;
            if F = null then
--                 Log.Error ("Frame is not linked to the correct parent");
--                 if not Check (Get_Root (Frame)) then
--                    Log.Error ("Check failed");
--                 else
--                    Log.Error ("Check is ok");
--                 end if;
--                 MAT.Frames.Print (Ada.Text_IO.Standard_Output, Get_Root (Frame));
               return;
            else
               F.Next := Frame.Next;
            end if;
         end if;
      end if;
--        Free (Frame);
   end Destroy;

   --  ------------------------------
   --  Release the frame when its reference is no longer necessary.
   --  ------------------------------
   procedure Release (Frame : in Frame_Type) is
      Current : Frame_Type := Frame;
   begin
      --  Scan the frame until the root is reached
      --  and decrement the used counter.  Free the frames
      --  when the used counter reaches 0.
      while Current /= null loop
         if Current.Used <= 1 then
            declare
               Tree : Frame_Type := Current;
            begin
               Current := Current.Parent;
               Destroy (Tree);
            end;
         else
            Current.Used := Current.Used - 1;
            Current := Current.Parent;
         end if;
      end loop;
      if not Check (Get_Root (Frame)) then
         Log.Error ("Frame is invalid");
      end if;
   end Release;

   --  ------------------------------
   --  Split the node pointed to by `F' at the position `Pos'
   --  in the caller chain.  A new parent is created for the node
   --  and the brothers of the node become the brothers of the
   --  new parent.
   --
   --  Returns in `F' the new parent node.
   --  ------------------------------
   procedure Split (F     : in out Frame_Type;
                    Pos   : in Positive) is

      --  Before:                       After:
      --
      --    +-------+             +-------+
      --  /-|  P    |           /-|  P    |
      --  | +-------+           | +-------+
      --  |       ^             |       ^
      --  |   +-------+         |    +-------+
      --  ...>| node  |...      ....>|  new  |...        (0..N brothers)
      --      +-------+              +-------+
      --       |     ^              |      ^
      --       | +-------+          | +-------+
      --       ->|  c    |          ->| node  |-->0      (0 brother)
      --         +-------+            +-------+
      --                                    |
      --                                +-------+
      --                                |   c   |
      --                                +-------+
      --
      New_Parent : constant Frame_Type := new Frame '(Parent      => F.Parent,
                                                      Next        => F.Next,
                                                      Children    => F,
                                                      Used        => F.Used - 1,
                                                      Depth       => F.Depth,
                                                      Local_Depth => Pos,
                                                      Calls       => (others => 0));
      Child : Frame_Type := F.Parent.Children;
   begin
      Log.Debug ("Split frame");

      --  Move the PC values in the new parent.
      New_Parent.Calls (1 .. Pos) := F.Calls (1 .. Pos);
      F.Calls (1 .. F.Local_Depth - Pos) := F.Calls (Pos + 1 .. F.Local_Depth);
      F.Parent         := New_Parent;
      F.Next           := null;
      F.Used           := F.Used - 1;
      New_Parent.Depth := F.Depth - F.Local_Depth + Pos;
      F.Local_Depth    := F.Local_Depth - Pos;

      --  Remove F from its parent children list and replace if with New_Parent.
      if Child = F then
         New_Parent.Parent.Children := New_Parent;
      else
         while Child.Next /= F loop
            Child := Child.Next;
         end loop;
         Child.Next := New_Parent;
      end if;
      F := New_Parent;
      if not Check (Get_Root (F)) then
         Log.Error ("Error when splitting frame");
      end if;
   end Split;

   procedure Add_Frame (F      : in Frame_Type;
                        Pc     : in Frame_Table;
                        Result : out Frame_Type) is
      Child         : Frame_Type := F;
      Pos           : Positive   := Pc'First;
      Current_Depth : Natural    := F.Depth;
      Cnt           : Local_Depth_Type;
   begin
      while Pos <= Pc'Last loop
         Cnt := Frame_Group_Size;
         if Pos + Cnt > Pc'Last then
            Cnt := Pc'Last - Pos + 1;
         end if;
         Current_Depth := Current_Depth + Cnt;
         Child := new Frame '(Parent      => Child,
                              Next        => Child.Children,
                              Children    => null,
                              Used        => 1,
                              Depth       => Current_Depth,
                              Local_Depth => Cnt,
                              Calls       => (others => 0));
         Child.Calls (1 .. Cnt) := Pc (Pos .. Pos + Cnt - 1);
         Pos := Pos + Cnt;
         Child.Parent.Children := Child;
         if not Check (Get_Root (Child)) then
            Log.Error ("Error when adding frame");
         end if;
      end loop;
      Result := Child;
   end Add_Frame;

   --  ------------------------------
   --  Insert in the frame tree the new stack frame represented by <tt>Pc</tt>.
   --  If the frame is already known, the frame reference counter is incremented.
   --  The frame represented by <tt>Pc</tt> is returned in <tt>Result</tt>.
   --  ------------------------------
   procedure Insert (Frame  : in Frame_Type;
                     Pc     : in Frame_Table;
                     Result : out Frame_Type) is
      Current : Frame_Type := Frame;
      Child   : Frame_Type;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive  := 1;
      Addr    : MAT.Types.Target_Addr;
   begin
      while Pos <= Pc'Last loop
         Addr := Pc (Pos);
         if Lpos <= Current.Local_Depth then
            if Addr = Current.Calls (Lpos) then
               Lpos := Lpos + 1;
               Pos  := Pos + 1;

               --  Split this node
            else
               Current.Used := Current.Used + 1;
               if Lpos > 1 then
                  Split (Current, Lpos - 1);
               end if;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
         else
            --  Find the first child which has the address.
            Child := Current.Children;
            while Child /= null loop
               exit when Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;
            if Child = null then
               Current.Used := Current.Used + 1;
               Add_Frame (Current, Pc (Pos .. Pc'Last), Result);
               return;
            end if;
            Current.Used := Current.Used + 1;
            Current := Child;
            Lpos    := 2;
            Pos     := Pos + 1;
         end if;
      end loop;
      if Lpos <= Current.Local_Depth then
         Split (Current, Lpos - 1);
      end if;
      Result := Current;
   end Insert;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in MAT.Types.Target_Addr) return Frame_Type is
      Child : Frame_Type := Frame.Children;
   begin
      while Child /= null loop
         if Child.Local_Depth >= 1 and then Child.Calls (1) = Pc then
            return Child;
         end if;
         Child := Child.Next;
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   function Find (Frame : in Frame_Type;
                  Pc    : in Frame_Table) return Frame_Type is
      Child : Frame_Type := Frame;
      Pos   : Positive  := Pc'First;
      Lpos  : Positive;
   begin
      while Pos <= Pc'Last loop
         Child := Find (Child, Pc (Pos));
         Pos  := Pos + 1;
         Lpos := 2;
         --  All the PC of the child frame must match.
         while Pos <= Pc'Last and Lpos <= Child.Local_Depth loop
            if Child.Calls (Lpos) /= Pc (Pos) then
               raise Not_Found;
            end if;
            Lpos := Lpos + 1;
            Pos  := Pos + 1;
         end loop;
      end loop;
      return Child;
   end Find;

   --  ------------------------------
   --  Find the child frame which has the given PC address.
   --  Returns that frame pointer or raises the Not_Found exception.
   --  ------------------------------
   procedure Find (Frame   : in Frame_Type;
                   Pc      : in Frame_Table;
                   Result  : out Frame_Type;
                   Last_Pc : out Natural) is
      Current : Frame_Type := Frame;
      Pos     : Positive  := Pc'First;
      Lpos    : Positive;
   begin
      Main_Search :
      while Pos <= Pc'Last loop
         declare
            Addr  : constant MAT.Types.Target_Addr := Pc (Pos);
            Child : Frame_Type  := Current.Children;
         begin
            --  Find the child which has the corresponding PC.
            loop
               exit Main_Search when Child = null;
               exit when Child.Local_Depth >= 1 and Child.Calls (1) = Addr;
               Child := Child.Next;
            end loop;

            Current := Child;
            Pos  := Pos + 1;
            Lpos := 2;
            --  All the PC of the child frame must match.
            while Pos <= Pc'Last and Lpos <= Current.Local_Depth loop
               exit Main_Search when Current.Calls (Lpos) /= Pc (Pos);
               Lpos := Lpos + 1;
               Pos  := Pos + 1;
            end loop;
         end;
      end loop Main_Search;
      Result := Current;
      if Pos > Pc'Last then
         Last_Pc := 0;
      else
         Last_Pc := Pos;
      end if;
   end Find;

end MAT.Frames;

Fix Backtrace operation to return a subset of the backtrace


-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;
               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Table_Definition_Access
                 := Table_Definition_Access (Table_List.Element (Table_Iter));
            begin
               Prepare_Table (Table);
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

-----------------------------------------------------------------------
--  gen-model-packages -- Packages holding model, query representation
--  Copyright (C) 2009, 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 and Name /= O.Pkg_Name then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;
               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Table_Definition_Access
                 := Table_Definition_Access (Table_List.Element (Table_Iter));
            begin
               Prepare_Table (Table);
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      Log.Info ("Preparing package {0}", O.Pkg_Name);

      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

Fix circular dependency of generated code - if the XML model definition has <many-to-one> relation that refer to the current package name, make sure the package name is not part of the 'with' clause list.