------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, 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 STMicroelectronics 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.   --
--                                                                          --
------------------------------------------------------------------------------

--  The file declares the main procedure for the demonstration. The LEDs
--  will blink "in a circle" on the board. The blue user button generates
--  an interrupt that changes the direction.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
--  The "last chance handler" is the user-defined routine that is called when
--  an exception is propagated. We need it in the executable, therefore it
--  must be somewhere in the closure of the context clauses.

with System;
with Interfaces;            use Interfaces;

with STM32.LCD;             use STM32.LCD;
with STM32.DMA2D.Interrupt; use STM32.DMA2D;
with STM32.RNG.Interrupts;  use STM32.RNG.Interrupts;

with Bitmapped_Drawing;     use Bitmapped_Drawing;
with Double_Buffer;         use Double_Buffer;

procedure Demo is
   use STM32;

   pragma Priority (System.Priority'First);

   type HSV_Color is record
      Hue : Byte;
      Sat : Byte;
      Val : Byte;
   end record;

   function To_RGB (Col : HSV_Color) return DMA2D_Color;
   --  Translates a Hue/Saturation/Value color into RGB

   type Coordinate is (X, Y);

   type Vector is array (Coordinate) of Float;

   function "+" (V1, V2 : Vector) return Vector
   is
   begin
      return (X => V1 (X) + V2 (X),
              Y => V1 (Y) + V2 (Y));
   end "+";

   function "-" (V1, V2 : Vector) return Vector
   is
   begin
      return (X => V1 (X) - V2 (X),
              Y => V1 (Y) - V2 (Y));
   end "-";

   function "*" (V1, V2 : Vector) return Float
   is
   begin
      return V1 (X) * V2 (X) + V1 (Y) * V2 (Y);
   end "*";

   function "*" (V : Vector; Val : Float) return Vector
   is
   begin
      return (V (X) * Val, V (Y) * Val);
   end "*";

   function "/" (V : Vector; Val : Float) return Vector
   is
   begin
      return (V (X) / Val, V (Y) / Val);
   end "/";

   type Moving_Object is record
      Center : Vector;
      Speed  : Vector;
      R      : Natural;
      Col    : HSV_Color;
      N_Hue  : Byte;
   end record;

   function I (F : Float) return Integer
     is (Integer (F));

   function Collides (M1, M2 : Moving_Object) return Boolean;
   procedure Handle_Collision (M1, M2 : in out Moving_Object);

   Objects      : array (1 .. 15) of Moving_Object;

--     LCD_Config   : LCD_Configuration;
   FG_Buffer    : DMA2D_Buffer;

   ------------
   -- To_RGB --
   ------------

   function To_RGB (Col : HSV_Color) return DMA2D_Color
   is
      V, S, H : Word;
      Region, FPart, p, q, t : Word;
      Ret     : DMA2D_Color;
   begin
      Ret.Alpha := 255;

      if Col.Sat = 0 then
         Ret.Red := Col.Val;
         Ret.Green := Col.Val;
         Ret.Blue  := Col.Val;

         return Ret;
      end if;

      V := Word (Col.Val);
      S := Word (Col.Sat);
      H := Word (Col.Hue);

      -- Hue in the range 0 .. 5
      Region := H / 43;
      --  Division reminder, multiplied by 6 to make it in range 0 .. 255
      FPart  := (H - (Region * 43)) * 6;

      P := Shift_Right (V * (255 - S), 8);
      Q := Shift_Right (V * (255 - Shift_Right (S * FPart, 8)), 8);
      T := Shift_Right (V * (255 - Shift_Right (S * (255 - FPart), 8)), 8);

      case Region is
         when 0 =>
            Ret.Red   := Byte (V);
            Ret.Green := Byte (T);
            Ret.Blue  := Byte (P);
         when 1 =>
            Ret.Red   := Byte (Q);
            Ret.Green := Byte (V);
            Ret.Blue  := Byte (P);
         when 2 =>
            Ret.Red   := Byte (P);
            Ret.Green := Byte (V);
            Ret.Blue  := Byte (T);
         when 3 =>
            Ret.Red   := Byte (P);
            Ret.Green := Byte (Q);
            Ret.Blue  := Byte (V);
         when 4 =>
            Ret.Red   := Byte (T);
            Ret.Green := Byte (P);
            Ret.Blue  := Byte (V);
         when others =>
            Ret.Red   := Byte (V);
            Ret.Green := Byte (P);
            Ret.Blue  := Byte (Q);
      end case;

      return Ret;
   end To_RGB;

   -------------
   -- Colides --
   -------------

   function Collides (M1, M2 : Moving_Object) return Boolean
   is
      Dist_Min_Square : constant Integer :=
                          (M1.R + M2.R) ** 2;
      M1_M2           : constant Vector := M2.Center - M1.Center;
      Dist_Square     : constant Integer :=
                          (I (M1_M2 (X)) ** 2 + I (M1_M2 (Y)) ** 2);
   begin
      return Dist_Square < Dist_Min_Square;
   end Collides;

   ----------------------
   -- Handle_Colisiton --
   ----------------------

   procedure Handle_Collision (M1, M2 : in out Moving_Object)
   is
      --  Dist: distance vector between the two objects
      Dist  : Vector;

      --  Projx: Projection of the speed of Mx on Dist
      Tmp   : Float;
      Proj1 : Vector;
      Proj2 : Vector;

      Tan_Sp1 : Vector;
      Tan_Sp2 : Vector;

      Sp1     : Vector;
      Sp2     : Vector;

      --  Simplified mass: equal to R
      Mass1   : constant Float := Float (M1.R);
      Mass2   : constant Float := Float (M2.R);
      dT      : Float := 0.0;
      Old1, Old2 : Vector;

   begin
      --  Move back before collision
      --  If we don't, then the balls might still be touching themselves
      --  after we execute this procedure, so collision is called a second
      --  time afterwards.
      Old1 := M1.Center;
      Old2 := M2.Center;
      loop
         dT := dT + 0.2;
         M1.Center := Old1 - M1.Speed * dT;
         M2.Center := Old2 - M2.Speed * dT;
         exit when not Collides (M1, M2);
      end loop;

      Dist := (M2.Center - M1.Center);

      --  Calculate the projection vector of the speeds on Dist
      Tmp := (M1.Speed * Dist) / (Dist * Dist);
      Proj1 := Dist * Tmp;
      Tmp := (M2.Speed * Dist) / (Dist * Dist);
      Proj2 := Dist * Tmp;

      --  Now retrieve the speed that is tangantial to dist
      Tan_Sp1 := M1.Speed - Proj1;
      Tan_Sp2 := M2.Speed - Proj2;

      --  Transfer the projected speed from one object to the other
      Sp1 := (Proj1 * (Mass1 - Mass2) + Proj2 * 2.0 * Mass2) / (Mass1 + Mass2);
      Sp2 := (Proj2 * (Mass2 - Mass1) + Proj1 * 2.0 * Mass1) / (Mass1 + Mass2);

      --  Calculate the final speed of the objects:
      --  initial tangantial speed + calculated projected speed
      M1.Speed := Sp1 + Tan_Sp1;
      M2.Speed := Sp2 + Tan_Sp2;

      --  Now replay from the time of the impact with the new speed
      M1.Center := M1.Center + M1.Speed * dT;
      M2.Center := M2.Center + M2.Speed * dT;
      M1.N_Hue  := M1.N_Hue + 32;
      M2.N_Hue  := M2.N_Hue + 32;
   end Handle_Collision;

   ----------------
   -- Init_Balls --
   ----------------

   procedure Init_Balls
   is
      Size   : constant Integer :=
                 Natural'Min (Pixel_Width, Pixel_Height);
      R_Min  : constant Natural :=
                 Size / 24;
      R_Var  : constant Word :=
                 Word (R_Min) * 4 / 5;
      SP_Max : constant Integer :=
                 Size / 7;
   begin
      for J in Objects'Range loop
         loop
            declare
               O     : Moving_Object renames Objects (J);
               R     : constant Integer :=
                         Integer (RNG.Interrupts.Random mod R_Var) + R_Min;
               Col   : constant Byte :=
                         Byte (RNG.Interrupts.Random mod 255);
               X_Raw : constant Word :=
                         (RNG.Interrupts.Random mod Word (Pixel_Width - 2 * R)) + Word (R);
               Y_Raw : constant Word :=
                         (RNG.Interrupts.Random mod Word (Pixel_Height - 2 * R)) + Word (R);
               Sp_X  : constant Integer :=
                         Integer (RNG.Interrupts.Random mod Word (SP_Max * 2 + 1)) - SP_Max;
               Sp_Y  : constant Integer :=
                         Integer (RNG.Interrupts.Random mod Word (SP_Max * 2 + 1)) - SP_Max;
               Redo  : Boolean := False;

            begin
               O :=
                 (Center => (Float (Natural (X_Raw) + R),
                             Float (Natural (Y_Raw) + R)),
                  Speed  => (Float (Sp_X) / 10.0,
                             Float (Sp_Y) / 10.0),
                  R      => R,
                  Col    => (Hue => Col,
                             Sat => 255,
                             Val => 255),
                  N_Hue  => Col);

               for K in Objects'First .. J - 1 loop
                  if Collides (O, Objects (K)) then
                     Redo := True;
                     exit;
                  end if;
               end loop;

               exit when not Redo;
            end;
         end loop;
      end loop;
   end Init_Balls;

begin
   STM32.LCD.Initialize (Pixel_Fmt_ARGB1555);
   STM32.DMA2D.Interrupt.Initialize;
   Double_Buffer.Initialize (Layer_Background => Layer_Double_Buffer,
                             Layer_Foreground => Layer_Inactive);
   STM32.RNG.Interrupts.Initialize_RNG;
--     STM32.Button.Initialize;

--     STM32.LCD.Set_Layer_Alpha (BG, 255);

   Init_Balls;

   loop
      FG_Buffer := Double_Buffer.Get_Hidden_Buffer (Background);
      STM32.DMA2D.DMA2D_Fill (FG_Buffer, Black);

      for M of Objects loop
         if M.N_Hue /= M.Col.Hue then
            M.Col.Hue := M.Col.Hue + 1;
         end if;
      end loop;

--        if STM32.Button.Has_Been_Pressed then
--           --           dY := - dY;
--           Init_Balls;
--        end if;

      for O of Objects loop
         O.Center := O.Center + O.Speed;

         if (O.Speed (X) < 0.0 and then I (O.Center (X)) <= O.R)
           or else (O.Speed (X) > 0.0
                    and then I (O.Center (X)) + O.R >= Pixel_Width - 1)
         then
            O.Speed (X) := -O.Speed (X);
            O.Center (X) := O.Center (X) + O.Speed (X);
         end if;

         if (O.Speed (Y) < 0.0 and then I (O.Center (Y)) <= O.R)
           or else (O.Speed (Y) > 0.0
                    and then I (O.Center (Y)) + O.R >= Pixel_Height - 1)
         then
            O.Speed (Y) := -O.Speed (Y);
            O.Center (Y) := O.Center (Y) + O.Speed (Y);
         end if;
      end loop;

      for J in Objects'First .. Objects'Last - 1 loop
         for K in J + 1 .. Objects'Last loop
            if Collides (Objects (J), Objects (K)) then
               Handle_Collision (Objects (J), Objects (K));
            end if;
         end loop;
      end loop;

      for O of Objects loop
         Fill_Circle
           (FG_Buffer,
            (X => I (O.Center (X)),
             Y => I (O.Center (Y))),
            O.R,
            To_RGB (O.Col));
      end loop;

      Swap_Buffers (Vsync => True);
   end loop;
end Demo;

------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, 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 STMicroelectronics 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.   --
--                                                                          --
------------------------------------------------------------------------------

--  The file declares the main procedure for the demonstration. The LEDs
--  will blink "in a circle" on the board. The blue user button generates
--  an interrupt that changes the direction.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
--  The "last chance handler" is the user-defined routine that is called when
--  an exception is propagated. We need it in the executable, therefore it
--  must be somewhere in the closure of the context clauses.

with System;
with Interfaces;            use Interfaces;

with STM32.Button;          use STM32.Button;
with STM32.LCD;             use STM32.LCD;
with STM32.DMA2D.Interrupt; use STM32.DMA2D;
with STM32.RNG.Interrupts;  use STM32.RNG.Interrupts;

with Bitmapped_Drawing;     use Bitmapped_Drawing;
with Double_Buffer;         use Double_Buffer;

procedure Demo is
   use STM32;

   pragma Priority (System.Priority'First);

   type HSV_Color is record
      Hue : Byte;
      Sat : Byte;
      Val : Byte;
   end record;

   function To_RGB (Col : HSV_Color) return DMA2D_Color;
   --  Translates a Hue/Saturation/Value color into RGB

   type Coordinate is (X, Y);

   type Vector is array (Coordinate) of Float;

   function "+" (V1, V2 : Vector) return Vector
   is
   begin
      return (X => V1 (X) + V2 (X),
              Y => V1 (Y) + V2 (Y));
   end "+";

   function "-" (V1, V2 : Vector) return Vector
   is
   begin
      return (X => V1 (X) - V2 (X),
              Y => V1 (Y) - V2 (Y));
   end "-";

   function "*" (V1, V2 : Vector) return Float
   is
   begin
      return V1 (X) * V2 (X) + V1 (Y) * V2 (Y);
   end "*";

   function "*" (V : Vector; Val : Float) return Vector
   is
   begin
      return (V (X) * Val, V (Y) * Val);
   end "*";

   function "/" (V : Vector; Val : Float) return Vector
   is
   begin
      return (V (X) / Val, V (Y) / Val);
   end "/";

   type Moving_Object is record
      Center : Vector;
      Speed  : Vector;
      R      : Natural;
      Col    : HSV_Color;
      N_Hue  : Byte;
   end record;

   function I (F : Float) return Integer
     is (Integer (F));

   function Collides (M1, M2 : Moving_Object) return Boolean;
   procedure Handle_Collision (M1, M2 : in out Moving_Object);

   Objects      : array (1 .. 15) of Moving_Object;

   FG_Buffer    : DMA2D_Buffer;
   White_Background : Boolean := False;

   ------------
   -- To_RGB --
   ------------

   function To_RGB (Col : HSV_Color) return DMA2D_Color
   is
      V, S, H : Word;
      Region, FPart, p, q, t : Word;
      Ret     : DMA2D_Color;
   begin
      Ret.Alpha := 255;

      if Col.Sat = 0 then
         Ret.Red := Col.Val;
         Ret.Green := Col.Val;
         Ret.Blue  := Col.Val;

         return Ret;
      end if;

      V := Word (Col.Val);
      S := Word (Col.Sat);
      H := Word (Col.Hue);

      -- Hue in the range 0 .. 5
      Region := H / 43;
      --  Division reminder, multiplied by 6 to make it in range 0 .. 255
      FPart  := (H - (Region * 43)) * 6;

      P := Shift_Right (V * (255 - S), 8);
      Q := Shift_Right (V * (255 - Shift_Right (S * FPart, 8)), 8);
      T := Shift_Right (V * (255 - Shift_Right (S * (255 - FPart), 8)), 8);

      case Region is
         when 0 =>
            Ret.Red   := Byte (V);
            Ret.Green := Byte (T);
            Ret.Blue  := Byte (P);
         when 1 =>
            Ret.Red   := Byte (Q);
            Ret.Green := Byte (V);
            Ret.Blue  := Byte (P);
         when 2 =>
            Ret.Red   := Byte (P);
            Ret.Green := Byte (V);
            Ret.Blue  := Byte (T);
         when 3 =>
            Ret.Red   := Byte (P);
            Ret.Green := Byte (Q);
            Ret.Blue  := Byte (V);
         when 4 =>
            Ret.Red   := Byte (T);
            Ret.Green := Byte (P);
            Ret.Blue  := Byte (V);
         when others =>
            Ret.Red   := Byte (V);
            Ret.Green := Byte (P);
            Ret.Blue  := Byte (Q);
      end case;

      return Ret;
   end To_RGB;

   -------------
   -- Colides --
   -------------

   function Collides (M1, M2 : Moving_Object) return Boolean
   is
      Dist_Min_Square : constant Integer :=
                          (M1.R + M2.R) ** 2;
      M1_M2           : constant Vector := M2.Center - M1.Center;
      Dist_Square     : constant Integer :=
                          (I (M1_M2 (X)) ** 2 + I (M1_M2 (Y)) ** 2);
   begin
      return Dist_Square < Dist_Min_Square;
   end Collides;

   ----------------------
   -- Handle_Colisiton --
   ----------------------

   procedure Handle_Collision (M1, M2 : in out Moving_Object)
   is
      --  Dist: distance vector between the two objects
      Dist  : Vector;

      --  Projx: Projection of the speed of Mx on Dist
      Tmp   : Float;
      Proj1 : Vector;
      Proj2 : Vector;

      Tan_Sp1 : Vector;
      Tan_Sp2 : Vector;

      Sp1     : Vector;
      Sp2     : Vector;

      --  Simplified mass: equal to R^2
      Mass1   : constant Float := Float (M1.R ** 2);
      Mass2   : constant Float := Float (M2.R ** 2);
      dT      : Float := 0.0;
      Old1, Old2 : Vector;

   begin
      --  Move back before collision
      --  If we don't, then the balls might still be touching themselves
      --  after we execute this procedure, so collision is called a second
      --  time afterwards.
      Old1 := M1.Center;
      Old2 := M2.Center;
      loop
         dT := dT + 0.2;
         M1.Center := Old1 - M1.Speed * dT;
         M2.Center := Old2 - M2.Speed * dT;
         exit when not Collides (M1, M2);
      end loop;

      Dist := (M2.Center - M1.Center);

      --  Calculate the projection vector of the speeds on Dist
      Tmp := (M1.Speed * Dist) / (Dist * Dist);
      Proj1 := Dist * Tmp;
      Tmp := (M2.Speed * Dist) / (Dist * Dist);
      Proj2 := Dist * Tmp;

      --  Now retrieve the speed that is tangantial to dist
      Tan_Sp1 := M1.Speed - Proj1;
      Tan_Sp2 := M2.Speed - Proj2;

      --  Transfer the projected speed from one object to the other
      Sp1 := (Proj1 * (Mass1 - Mass2) + Proj2 * 2.0 * Mass2) / (Mass1 + Mass2);
      Sp2 := (Proj2 * (Mass2 - Mass1) + Proj1 * 2.0 * Mass1) / (Mass1 + Mass2);

      --  Calculate the final speed of the objects:
      --  initial tangantial speed + calculated projected speed
      M1.Speed := Sp1 + Tan_Sp1;
      M2.Speed := Sp2 + Tan_Sp2;

      --  Now replay from the time of the impact with the new speed
      M1.Center := M1.Center + M1.Speed * dT;
      M2.Center := M2.Center + M2.Speed * dT;
      M1.N_Hue  := M1.N_Hue + 32;
      M2.N_Hue  := M2.N_Hue + 32;
   end Handle_Collision;

   ----------------
   -- Init_Balls --
   ----------------

   procedure Init_Balls
   is
      Size   : constant Integer :=
                 Natural'Min (Pixel_Width, Pixel_Height);
      R_Min  : constant Natural :=
                 Size / 24;
      R_Var  : constant Word :=
                 Word (R_Min) * 4 / 5;
      SP_Max : constant Integer :=
                 Size / 7;
   begin
      for J in Objects'Range loop
         loop
            declare
               O     : Moving_Object renames Objects (J);
               R     : constant Integer :=
                         Integer (RNG.Interrupts.Random mod R_Var) + R_Min;
               Col   : constant Byte :=
                         Byte (RNG.Interrupts.Random mod 255);
               X_Raw : constant Word :=
                         (RNG.Interrupts.Random mod Word (Pixel_Width - 2 * R)) + Word (R);
               Y_Raw : constant Word :=
                         (RNG.Interrupts.Random mod Word (Pixel_Height - 2 * R)) + Word (R);
               Sp_X  : constant Integer :=
                         Integer (RNG.Interrupts.Random mod Word (SP_Max * 2 + 1)) - SP_Max;
               Sp_Y  : constant Integer :=
                         Integer (RNG.Interrupts.Random mod Word (SP_Max * 2 + 1)) - SP_Max;
               Redo  : Boolean := False;

            begin
               O :=
                 (Center => (Float (Natural (X_Raw) + R),
                             Float (Natural (Y_Raw) + R)),
                  Speed  => (Float (Sp_X) / 10.0,
                             Float (Sp_Y) / 10.0),
                  R      => R,
                  Col    => (Hue => Col,
                             Sat => 255,
                             Val => 255),
                  N_Hue  => Col);

               for K in Objects'First .. J - 1 loop
                  if Collides (O, Objects (K)) then
                     Redo := True;
                     exit;
                  end if;
               end loop;

               exit when not Redo;
            end;
         end loop;
      end loop;
   end Init_Balls;

begin
   STM32.LCD.Initialize (Pixel_Fmt_ARGB1555);
   STM32.DMA2D.Interrupt.Initialize;
   Double_Buffer.Initialize (Layer_Background => Layer_Double_Buffer,
                             Layer_Foreground => Layer_Inactive);
   STM32.RNG.Interrupts.Initialize_RNG;
   STM32.Button.Initialize;

   Init_Balls;

   loop
      if STM32.Button.Has_Been_Pressed then
         White_Background := not White_Background;
      end if;

      FG_Buffer := Double_Buffer.Get_Hidden_Buffer (Background);

      STM32.DMA2D.DMA2D_Fill
        (FG_Buffer,
         (if White_Background then White else Black));

      for M of Objects loop
         if M.N_Hue /= M.Col.Hue then
            M.Col.Hue := M.Col.Hue + 1;
         end if;
      end loop;

      for O of Objects loop
         O.Center := O.Center + O.Speed;

         if (O.Speed (X) < 0.0 and then I (O.Center (X)) <= O.R)
           or else (O.Speed (X) > 0.0
                    and then I (O.Center (X)) + O.R >= Pixel_Width - 1)
         then
            O.Speed (X) := -O.Speed (X);
            O.Center (X) := O.Center (X) + O.Speed (X);
         end if;

         if (O.Speed (Y) < 0.0 and then I (O.Center (Y)) <= O.R)
           or else (O.Speed (Y) > 0.0
                    and then I (O.Center (Y)) + O.R >= Pixel_Height - 1)
         then
            O.Speed (Y) := -O.Speed (Y);
            O.Center (Y) := O.Center (Y) + O.Speed (Y);
         end if;
      end loop;

      for J in Objects'First .. Objects'Last - 1 loop
         for K in J + 1 .. Objects'Last loop
            if Collides (Objects (J), Objects (K)) then
               Handle_Collision (Objects (J), Objects (K));
            end if;
         end loop;
      end loop;

      for O of Objects loop
         Fill_Circle
           (FG_Buffer,
            (X => I (O.Center (X)),
             Y => I (O.Center (Y))),
            O.R,
            To_RGB (O.Col));
      end loop;

      Swap_Buffers (Vsync => True);
   end loop;
end Demo;

Improve the "Balls" example by switching the background color upon button.


-----------------------------------------------------------------------
--  util-beans-objects-tests -- Unit tests for objects
--  Copyright (C) 2017 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 Util.Test_Caller;
with Util.Beans.Objects.Maps;
package body Util.Beans.Objects.Tests is

   package Caller is new Util.Test_Caller (Test, "Objects");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Is_Array",
                       Test_Is_Array'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Get_Count",
                       Test_Get_Count'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Get_Value",
                       Test_Get_Value'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Set_Value",
                       Test_Set_Value'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the creation, initialization and retrieval of objects holding arrays.
   --  ------------------------------
   procedure Test_Is_Array (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      T.Assert (not Is_Null (Value), "Array object must not be null");
      T.Assert (not Is_Empty (Value), "Array object must not be empty");
      T.Assert (Is_Array (Value), "Array object must be an array");
      for I in List'Range loop
         T.Assert (not Is_Array (List (I)), "Is_Array returned true for non array object");
      end loop;
      T.Assert (not Is_Array (Null_Object), "The Null_Object is not an array");
   end Test_Is_Array;

   --  ------------------------------
   --  Test the Get_Count operation.
   --  ------------------------------
   procedure Test_Get_Count (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      Util.Tests.Assert_Equals (T, List'Length, Get_Count (Value), "Get_Count is invalid");
      Util.Tests.Assert_Equals (T, 0, Get_Count (Null_Object), "Get_Count is invalid");
   end Test_Get_Count;

   --  ------------------------------
   --  Test the Get_Value operation.
   --  ------------------------------
   procedure Test_Get_Value (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
      Item  : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      for I in 1 .. Get_Count (Value) loop
         Item := Get_Value (Value, I);
         T.Assert (not Is_Null (Item), "Item at " & Positive'Image (I) & " is null");
      end loop;
   end Test_Get_Value;

   --  ------------------------------
   --  Test the Set_Value operation.
   --  ------------------------------
   procedure Test_Set_Value (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object := Maps.Create;
      Item  : Object;
   begin
      Set_Value (Value, "username", To_Object (String '("joe")));
      Set_Value (Value, "age", To_Object (Integer (32)));
      Util.Tests.Assert_Equals (T, "joe", To_String (Get_Value (Value, "username")));
      Util.Tests.Assert_Equals (T, 32, To_Integer (Get_Value (Value, "age")));
   end Test_Set_Value;

end Util.Beans.Objects.Tests;

-----------------------------------------------------------------------
--  util-beans-objects-tests -- Unit tests for objects
--  Copyright (C) 2017 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 Util.Test_Caller;
with Util.Beans.Objects.Maps;
package body Util.Beans.Objects.Tests is

   package Caller is new Util.Test_Caller (Test, "Objects");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Is_Array",
                       Test_Is_Array'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Get_Count",
                       Test_Get_Count'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Get_Value",
                       Test_Get_Value'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Set_Value",
                       Test_Set_Value'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the creation, initialization and retrieval of objects holding arrays.
   --  ------------------------------
   procedure Test_Is_Array (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      T.Assert (not Is_Null (Value), "Array object must not be null");
      T.Assert (not Is_Empty (Value), "Array object must not be empty");
      T.Assert (Is_Array (Value), "Array object must be an array");
      for I in List'Range loop
         T.Assert (not Is_Array (List (I)), "Is_Array returned true for non array object");
      end loop;
      T.Assert (not Is_Array (Null_Object), "The Null_Object is not an array");
   end Test_Is_Array;

   --  ------------------------------
   --  Test the Get_Count operation.
   --  ------------------------------
   procedure Test_Get_Count (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      Util.Tests.Assert_Equals (T, List'Length, Get_Count (Value), "Get_Count is invalid");
      Util.Tests.Assert_Equals (T, 0, Get_Count (Null_Object), "Get_Count is invalid");
   end Test_Get_Count;

   --  ------------------------------
   --  Test the Get_Value operation.
   --  ------------------------------
   procedure Test_Get_Value (T : in out Test) is
      List  : Object_Array (1 .. 10);
      Value : Object;
      Item  : Object;
   begin
      for I in List'Range loop
         List (I) := To_Object (I);
      end loop;
      Value := To_Object (List);
      for I in 1 .. Get_Count (Value) loop
         Item := Get_Value (Value, I);
         T.Assert (not Is_Null (Item), "Item at " & Positive'Image (I) & " is null");
      end loop;
   end Test_Get_Value;

   --  ------------------------------
   --  Test the Set_Value operation.
   --  ------------------------------
   procedure Test_Set_Value (T : in out Test) is
      Value : constant Object := Maps.Create;
   begin
      Set_Value (Value, "username", To_Object (String '("joe")));
      Set_Value (Value, "age", To_Object (Integer (32)));
      Util.Tests.Assert_Equals (T, "joe", To_String (Get_Value (Value, "username")));
      Util.Tests.Assert_Equals (T, 32, To_Integer (Get_Value (Value, "age")));
   end Test_Set_Value;

end Util.Beans.Objects.Tests;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  schemas Tests -- Test loading of database schema
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 2018 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

-----------------------------------------------------------------------
--  schemas Tests -- Test loading of database schema
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 2018 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.Directories;

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;

   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Add test to verify the Get_Size function on the column


-----------------------------------------------------------------------
--  ado-audits-tests -- Audit tests
--  Copyright (C) 2018, 2019 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 Util.Test_Caller;
with Util.Strings;

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   use type ADO.Objects.Object_Key_Type;

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      pragma Unreferenced (Manager);

      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            if Object.Key_Type = ADO.Objects.KEY_INTEGER then
               Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            end if;
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      Prop   : Regtests.Audits.Model.Property_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      for I in 1 .. 10 loop
         Prop.Set_Value ((Value => I, Is_Null => False));
         Prop.Set_Float_Value (3.0 * Float (I));
         Prop.Save (DB);
      end loop;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

-----------------------------------------------------------------------
--  ado-audits-tests -- Audit tests
--  Copyright (C) 2018, 2019 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 Util.Test_Caller;
with Util.Strings;

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   use type ADO.Objects.Object_Key_Type;

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      pragma Unreferenced (Manager);

      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            if Object.Key_Type = ADO.Objects.KEY_INTEGER then
               Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            end if;
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      Prop   : Regtests.Audits.Model.Property_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      Prop.set_Id (Util.Tests.Get_Uuid);
      for I in 1 .. 10 loop
         Prop.Set_Value ((Value => I, Is_Null => False));
         Prop.Set_Float_Value (3.0 * Float (I));
         Prop.Save (DB);
      end loop;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

Fix running the test several times: avoid duplicate key when inserting a property for the test


-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Permissions.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Permissions.Controller_Access;
      use type Security.Permissions.Permission_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Permissions.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            Result := C.Has_Permission (Context);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Permissions.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Permissions.Controller_Access;
      use type Security.Permissions.Permission_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Permissions.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            Result := C.Has_Permission (Context);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Use the Principal from the Security package