-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011, 2012, 2016, 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 Ada.Strings.Unbounded;
with Ada.Streams;
with Util.Streams.Texts;
with Util.Stacks;
with Util.Beans.Objects;
package Util.Serialize.IO.JSON is

   --  ------------------------------
   --  JSON Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating a JSON output stream.
   --  The stream object takes care of the JSON escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Start a JSON document.  This operation writes the initial JSON marker ('{').
   overriding
   procedure Start_Document (Stream : in out Output_Stream);

   --  Finish a JSON document by writing the final JSON marker ('}').
   overriding
   procedure End_Document (Stream : in out Output_Stream);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Start a new JSON object.  If the name is not empty, write it as a string
   --  followed by the ':' (colon).  The JSON object starts with '{' (curly brace).
   --  Example:   "list": {
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current JSON object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a JSON name/value pair.  The value is written according to its type
   --  Example:  "name": null
   --            "name": false
   --            "name": 12
   --            "name": "value"
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the attribute with a null value.
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String);

   --  Write a JSON name/value pair (see Write_Attribute).
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Write an entity with a null value.
   overriding
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String);

   --  Starts a JSON array.
   --  Example:  "list": [
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a JSON array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Read a JSON file and return an object.
   function Read (Path : in String) return Util.Beans.Objects.Object;

private

   type Node_Info is record
      Is_Array   : Boolean := False;
      Is_Root    : Boolean := False;
      Has_Fields : Boolean := False;
   end record;
   type Node_Info_Access is access all Node_Info;

   package Node_Info_Stack is new Util.Stacks (Element_Type => Node_Info,
                                               Element_Type_Access => Node_Info_Access);

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Stack  : Node_Info_Stack.Stack;
      Stream : Util.Streams.Texts.Print_Stream_Access;
   end record;

   procedure Write_Field_Name (Stream : in out Output_Stream;
                               Name   : in String);

   type Token_Type is (T_EOF, T_LEFT_BRACE, T_RIGHT_BRACE, T_LEFT_BRACKET,
                       T_RIGHT_BRACKET, T_COLON, T_COMMA, T_TRUE, T_FALSE,
                       T_STRING, T_NUMBER, T_BOOLEAN, T_UNKNOWN, T_NULL);

   type Parser is new Util.Serialize.IO.Parser with record
      Token            : Ada.Strings.Unbounded.Unbounded_String;
      Pending_Token    : Token_Type := T_EOF;
      Line_Number      : Natural  := 1;
      Has_Pending_Char : Boolean := False;
      Pending_Char     : Character;
   end record;

end Util.Serialize.IO.JSON;

-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011, 2012, 2016, 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 Ada.Strings.Unbounded;
with Ada.Streams;
with Util.Streams.Texts;
with Util.Stacks;
with Util.Beans.Objects;
package Util.Serialize.IO.JSON is

   --  ------------------------------
   --  JSON Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating a JSON output stream.
   --  The stream object takes care of the JSON escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Start a JSON document.  This operation writes the initial JSON marker ('{').
   overriding
   procedure Start_Document (Stream : in out Output_Stream);

   --  Finish a JSON document by writing the final JSON marker ('}').
   overriding
   procedure End_Document (Stream : in out Output_Stream);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a JSON string.  Special characters are escaped using the JSON
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Start a new JSON object.  If the name is not empty, write it as a string
   --  followed by the ':' (colon).  The JSON object starts with '{' (curly brace).
   --  Example:   "list": {
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current JSON object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   --  Write a JSON name/value pair.  The value is written according to its type
   --  Example:  "name": null
   --            "name": false
   --            "name": 12
   --            "name": "value"
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the attribute with a null value.
   overriding
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String);

   --  Write a JSON name/value pair (see Write_Attribute).
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Write a JSON name/value pair (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   --  Write an entity with a null value.
   overriding
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String);

   --  Starts a JSON array.
   --  Example:  "list": [
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a JSON array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   type Parser is new Serialize.IO.Parser with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Input_Buffer_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Read a JSON file and return an object.
   function Read (Path : in String) return Util.Beans.Objects.Object;

private

   type Node_Info is record
      Is_Array   : Boolean := False;
      Is_Root    : Boolean := False;
      Has_Fields : Boolean := False;
   end record;
   type Node_Info_Access is access all Node_Info;

   package Node_Info_Stack is new Util.Stacks (Element_Type => Node_Info,
                                               Element_Type_Access => Node_Info_Access);

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Stack  : Node_Info_Stack.Stack;
      Stream : Util.Streams.Texts.Print_Stream_Access;
   end record;

   procedure Write_Field_Name (Stream : in out Output_Stream;
                               Name   : in String);

   type Token_Type is (T_EOF, T_LEFT_BRACE, T_RIGHT_BRACE, T_LEFT_BRACKET,
                       T_RIGHT_BRACKET, T_COLON, T_COMMA, T_TRUE, T_FALSE,
                       T_STRING, T_NUMBER, T_BOOLEAN, T_UNKNOWN, T_NULL);

   type Parser is new Util.Serialize.IO.Parser with record
      Token            : Ada.Strings.Unbounded.Unbounded_String;
      Pending_Token    : Token_Type := T_EOF;
      Line_Number      : Natural  := 1;
      Has_Pending_Char : Boolean := False;
      Pending_Char     : Character;
   end record;

end Util.Serialize.IO.JSON;

Use the Input_Buffer_Stream instead of Buffered_Stream


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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.

private with Ada.Finalization;
private with Ada.Strings.Unbounded;

private with AWT.Gamepads;

package AWT.Inputs.Gamepads with SPARK_Mode => On is
   pragma Preelaborate;

   type Connection_Kind is (Disconnected, Wired, Wireless);

   type GUID_String is new String (1 .. 32)
     with Dynamic_Predicate => (for all C of GUID_String => C in '0' .. '9' | 'a' .. 'f');

   --  FIXME Support motion sensor

   type Normalized is new Float range 0.0 .. 1.0;

   ----------------------------------------------------------------------------

   type Gamepad_Button is
     (Direction_Up,
      Direction_Right,
      Direction_Down,
      Direction_Left,
      Action_Down,
      Action_Right,
      Action_Left,
      Action_Up,
      Shoulder_Left,
      Shoulder_Right,
      Thumb_Left,
      Thumb_Right,
      Center_Left,
      Center_Right,
      Center_Logo);

   type Gamepad_Axis is
     (Stick_Left_X,
      Stick_Left_Y,
      Stick_Right_X,
      Stick_Right_Y);

   type Gamepad_Trigger is
     (Trigger_Left,
      Trigger_Right);

   type Gamepad_Buttons is array (Gamepad_Button) of Button_State
     with Component_Size => 1;

   type Changed_Gamepad_Buttons is array (Gamepad_Button) of Boolean
     with Component_Size => 1;

   type Axis_Position is delta 2.0 ** (-15) range -1.0 .. 1.0 - 2.0 ** (-15)
     with Small => 2.0 ** (-15),
          Size  => 16;

   type Trigger_Position is delta 2.0 ** (-8) range 0.0 .. 1.0 - 2.0 ** (-8)
     with Small => 2.0 ** (-8),
          Size  => 8;

   type Gamepad_Axes is array (Gamepad_Axis) of Axis_Position;

   type Gamepad_Triggers is array (Gamepad_Trigger) of Trigger_Position;

   type Gamepad_State is record
      Buttons   : Gamepad_Buttons         := (others => Released);
      Pressed   : Changed_Gamepad_Buttons := (others => False);
      Released  : Changed_Gamepad_Buttons := (others => False);

      Axes     : Gamepad_Axes     := (others => 0.0);
      Triggers : Gamepad_Triggers := (others => 0.0);
   end record;

   ----------------------------------------------------------------------------

   type Battery_Capacity is range 0 .. 100;

   type Battery_Status is (Discharging, Charging, Not_Charging);

   type Battery_State (Is_Present : Boolean := False) is record
      case Is_Present is
         when True =>
            Capacity : Battery_Capacity;
            Status   : Battery_Status;
         when False =>
            null;
      end case;
   end record;

   ----------------------------------------------------------------------------

   type Color_Kind is (Red, Green, Blue);

   type RGB_Color is array (Color_Kind) of Normalized;

   type LED_State (Is_Present : Boolean := False) is record
      case Is_Present is
         when True =>
            Brightness : Normalized;
            Color      : RGB_Color;
         when False =>
            null;
      end case;
   end record;

   ----------------------------------------------------------------------------

   type Gamepad is tagged limited private;

   function Name (Object : Gamepad) return String;

   function Serial_Number (Object : Gamepad) return String;

   function GUID (Object : Gamepad) return GUID_String;

   function Connection (Object : Gamepad) return Connection_Kind;

   function State (Object : in out Gamepad) return Gamepad_State;

   function State (Object : Gamepad) return Battery_State;

   function State (Object : Gamepad) return LED_State;

   procedure Set_LED
     (Object     : in out Gamepad;
      Brightness : Normalized;
      Color      : RGB_Color);

   type Effect is private;

   function Rumble_Effect
     (Length, Offset : Duration;
      Strong, Weak   : Normalized) return Effect;

   function Periodic_Effect
     (Length, Offset : Duration;
      Magnitude      : Normalized;
      Attack, Fade   : Duration) return Effect;

   procedure Play_Effect (Object : in out Gamepad; Subject : Effect);

   procedure Cancel_Effect (Object : in out Gamepad; Subject : Effect);

   function Effects (Object : Gamepad) return Natural;

   procedure Log_Information (Object : Gamepad);

   ----------------------------------------------------------------------------

   procedure Set_Mappings (Text : String);

   procedure Initialize;

   procedure Poll;

   type Gamepad_Ptr is not null access all Gamepad;

   type Gamepad_Array is array (Positive range <>) of Gamepad_Ptr;

   function Gamepads return Gamepad_Array;

   ----------------------------------------------------------------------------

   type Gamepad_Event_Listener is abstract tagged limited private;

   procedure On_Connect
     (Object  : Gamepad_Event_Listener;
      Gamepad : Gamepad_Ptr) is abstract;

   procedure On_Disconnect
     (Object  : Gamepad_Event_Listener;
      Gamepad : Gamepad_Ptr) is abstract;

private

   type Axis_Value is delta 2.0 ** (-16)
     range -(2.0 ** 47) ..
           +(2.0 ** 47 - 2.0 ** (-16));

   type Output_Kind is (Button, Axis, Trigger, None);

   type Output_Mapping (Kind : Output_Kind := None) is record
      case Kind is
         when Axis =>
            Axis    : AWT.Inputs.Gamepads.Gamepad_Axis;
            Scale   : Axis_Value := 2.0;
            Offset  : Axis_Value := 1.0;
         when Trigger =>
            Trigger : AWT.Inputs.Gamepads.Gamepad_Trigger;
         when Button =>
            Button  : AWT.Inputs.Gamepads.Gamepad_Button;
         when None =>
            null;
      end case;
   end record;

   type Side_Type is (Negative_Half, Positive_Half, Full_Range);

   subtype Hat_Side is Side_Type range Negative_Half .. Positive_Half;

   type Axis_Modifier is record
      Offset, Scale, Resolution : Axis_Value;
   end record;

   type Input_Mapping is record
      Modifier : Axis_Modifier;

      Side   : Side_Type := Full_Range;
      Invert : Boolean   := False;
   end record;

   type Mapping (Kind : Output_Kind := None) is record
      Input  : Input_Mapping;
      Output : Output_Mapping (Kind);
   end record;

   type Axis_Mappings is array (AWT.Gamepads.Input_Axis) of Mapping;
   type Key_Mappings  is array (AWT.Gamepads.Input_Button) of Mapping;
   type Hat_Mappings  is array (AWT.Gamepads.Input_Hat, Hat_Side) of Mapping;

   type Gamepad is limited new AWT.Gamepads.Abstract_Gamepad with record
      Name, ID    : SU.Unbounded_String;
      GUID        : GUID_String;
      Gamepad     : Gamepad_State;

      Axes : Axis_Mappings;
      Keys : Key_Mappings;
      Hats : Hat_Mappings;

      Has_Rumble  : Boolean := False;
      Initialized : Boolean := False;
      Max_Effects : Natural := 0;
   end record;

   ----------------------------------------------------------------------------

   type Effect is new AWT.Gamepads.Abstract_Effect;

   ----------------------------------------------------------------------------

   type Gamepad_Event_Listener is
     abstract limited new Ada.Finalization.Limited_Controlled with null record;

   overriding procedure Initialize (Object : in out Gamepad_Event_Listener);
   overriding procedure Finalize   (Object : in out Gamepad_Event_Listener);

end AWT.Inputs.Gamepads;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2021 onox <denkpadje@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.

private with Ada.Finalization;
private with Ada.Strings.Unbounded;

private with AWT.Gamepads;

package AWT.Inputs.Gamepads with SPARK_Mode => On is
   pragma Preelaborate;

   type Connection_Kind is (Disconnected, Wired, Wireless);

   type GUID_String is new String (1 .. 32)
     with Dynamic_Predicate => (for all C of GUID_String => C in '0' .. '9' | 'a' .. 'f');

   type Normalized is new Float range 0.0 .. 1.0;

   ----------------------------------------------------------------------------

   type Gamepad_Button is
     (Direction_Up,
      Direction_Right,
      Direction_Down,
      Direction_Left,
      Action_Down,
      Action_Right,
      Action_Left,
      Action_Up,
      Shoulder_Left,
      Shoulder_Right,
      Thumb_Left,
      Thumb_Right,
      Center_Left,
      Center_Right,
      Center_Logo);

   type Gamepad_Axis is
     (Stick_Left_X,
      Stick_Left_Y,
      Stick_Right_X,
      Stick_Right_Y);

   type Gamepad_Trigger is
     (Trigger_Left,
      Trigger_Right);

   type Gamepad_Buttons is array (Gamepad_Button) of Button_State
     with Component_Size => 1;

   type Changed_Gamepad_Buttons is array (Gamepad_Button) of Boolean
     with Component_Size => 1;

   type Axis_Position is delta 2.0 ** (-15) range -1.0 .. 1.0 - 2.0 ** (-15)
     with Small => 2.0 ** (-15),
          Size  => 16;

   type Trigger_Position is delta 2.0 ** (-8) range 0.0 .. 1.0 - 2.0 ** (-8)
     with Small => 2.0 ** (-8),
          Size  => 8;

   type Gamepad_Axes is array (Gamepad_Axis) of Axis_Position;

   type Gamepad_Triggers is array (Gamepad_Trigger) of Trigger_Position;

   type Gamepad_State is record
      Buttons   : Gamepad_Buttons         := (others => Released);
      Pressed   : Changed_Gamepad_Buttons := (others => False);
      Released  : Changed_Gamepad_Buttons := (others => False);

      Axes     : Gamepad_Axes     := (others => 0.0);
      Triggers : Gamepad_Triggers := (others => 0.0);
   end record;

   ----------------------------------------------------------------------------

   type Battery_Capacity is range 0 .. 100;

   type Battery_Status is (Discharging, Charging, Not_Charging);

   type Battery_State (Is_Present : Boolean := False) is record
      case Is_Present is
         when True =>
            Capacity : Battery_Capacity;
            Status   : Battery_Status;
         when False =>
            null;
      end case;
   end record;

   ----------------------------------------------------------------------------

   type Color_Kind is (Red, Green, Blue);

   type RGB_Color is array (Color_Kind) of Normalized;

   type LED_State (Is_Present : Boolean := False) is record
      case Is_Present is
         when True =>
            Brightness : Normalized;
            Color      : RGB_Color;
         when False =>
            null;
      end case;
   end record;

   ----------------------------------------------------------------------------

   type Sensor_Axis_Value is delta 2.0 ** (-16) range -(2.0 ** 15) .. +(2.0 ** 15 - 2.0 ** (-16))
     with Small => 2.0 ** (-16),
          Size  => 32;

   type Sensor_Axis is (X, Y, Z, Rx, Ry, Rz);

   type Sensor_Axes is array (Sensor_Axis) of Sensor_Axis_Value;

   type Motion_State (Is_Present : Boolean := False)  is record
      case Is_Present is
         when True =>
            Axes : Sensor_Axes := (others => 0.0);
         when False =>
            null;
      end case;
   end record;

   ----------------------------------------------------------------------------

   type Gamepad is tagged limited private;

   function Name (Object : Gamepad) return String;

   function Serial_Number (Object : Gamepad) return String;

   function GUID (Object : Gamepad) return GUID_String;

   function Connection (Object : Gamepad) return Connection_Kind;

   function State (Object : in out Gamepad) return Gamepad_State;

   function State (Object : Gamepad) return Motion_State;

   function State (Object : Gamepad) return Battery_State;

   function State (Object : Gamepad) return LED_State;

   procedure Set_LED
     (Object     : in out Gamepad;
      Brightness : Normalized;
      Color      : RGB_Color);

   type Effect is private;

   function Rumble_Effect
     (Length, Offset : Duration;
      Strong, Weak   : Normalized) return Effect;

   function Periodic_Effect
     (Length, Offset : Duration;
      Magnitude      : Normalized;
      Attack, Fade   : Duration) return Effect;

   procedure Play_Effect (Object : in out Gamepad; Subject : Effect);

   procedure Cancel_Effect (Object : in out Gamepad; Subject : Effect);

   function Effects (Object : Gamepad) return Natural;

   procedure Log_Information (Object : Gamepad);

   ----------------------------------------------------------------------------

   procedure Set_Mappings (Text : String);

   procedure Initialize;

   procedure Poll;

   type Gamepad_Ptr is not null access all Gamepad;

   type Gamepad_Array is array (Positive range <>) of Gamepad_Ptr;

   function Gamepads return Gamepad_Array;

   ----------------------------------------------------------------------------

   type Gamepad_Event_Listener is abstract tagged limited private;

   procedure On_Connect
     (Object  : Gamepad_Event_Listener;
      Gamepad : Gamepad_Ptr) is abstract;

   procedure On_Disconnect
     (Object  : Gamepad_Event_Listener;
      Gamepad : Gamepad_Ptr) is abstract;

private

   type Axis_Value is delta 2.0 ** (-16)
     range -(2.0 ** 47) ..
           +(2.0 ** 47 - 2.0 ** (-16));

   type Output_Kind is (Button, Axis, Trigger, None);

   type Output_Mapping (Kind : Output_Kind := None) is record
      case Kind is
         when Axis =>
            Axis    : AWT.Inputs.Gamepads.Gamepad_Axis;
            Scale   : Axis_Value := 2.0;
            Offset  : Axis_Value := 1.0;
         when Trigger =>
            Trigger : AWT.Inputs.Gamepads.Gamepad_Trigger;
         when Button =>
            Button  : AWT.Inputs.Gamepads.Gamepad_Button;
         when None =>
            null;
      end case;
   end record;

   type Side_Type is (Negative_Half, Positive_Half, Full_Range);

   subtype Hat_Side is Side_Type range Negative_Half .. Positive_Half;

   type Axis_Modifier is record
      Offset, Scale, Resolution : Axis_Value;
   end record;

   type Input_Mapping is record
      Modifier : Axis_Modifier;

      Side   : Side_Type := Full_Range;
      Invert : Boolean   := False;
   end record;

   type Mapping (Kind : Output_Kind := None) is record
      Input  : Input_Mapping;
      Output : Output_Mapping (Kind);
   end record;

   type Axis_Mappings is array (AWT.Gamepads.Input_Axis) of Mapping;
   type Key_Mappings  is array (AWT.Gamepads.Input_Button) of Mapping;
   type Hat_Mappings  is array (AWT.Gamepads.Input_Hat, Hat_Side) of Mapping;

   type Sensor_Modifiers is array (AWT.Gamepads.Sensor_Axis) of Axis_Modifier;

   type Gamepad is limited new AWT.Gamepads.Abstract_Gamepad with record
      Name, ID    : SU.Unbounded_String;
      GUID        : GUID_String;

      Gamepad : Gamepad_State;
      Sensor  : Motion_State;

      Axes : Axis_Mappings;
      Keys : Key_Mappings;
      Hats : Hat_Mappings;

      Sensors : Sensor_Modifiers;

      Has_Rumble  : Boolean := False;
      Initialized : Boolean := False;
      Max_Effects : Natural := 0;
   end record;

   ----------------------------------------------------------------------------

   type Effect is new AWT.Gamepads.Abstract_Effect;

   ----------------------------------------------------------------------------

   type Gamepad_Event_Listener is
     abstract limited new Ada.Finalization.Limited_Controlled with null record;

   overriding procedure Initialize (Object : in out Gamepad_Event_Listener);
   overriding procedure Finalize   (Object : in out Gamepad_Event_Listener);

end AWT.Inputs.Gamepads;

awt: Add support for motion sensor of gamepads

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  ADO Statements -- Database statements
--  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.
-----------------------------------------------------------------------

package body ADO.Statements.Create is

   --  ------------------------------
   --  Create the query statement
   --  ------------------------------
   function Create_Statement (Proxy : Query_Statement_Access) return Query_Statement is
   begin
      return Result : Query_Statement do
         Result.Query := Proxy.Get_Query;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create the delete statement
   --  ------------------------------
   function Create_Statement (Proxy : Delete_Statement_Access) return Delete_Statement is
   begin
      return Result : Delete_Statement do
         Result.Query := Proxy.Get_Query;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Proxy : Update_Statement_Access) return Update_Statement is
   begin
      return Result : Update_Statement do
         Result.Update := Proxy.Get_Update_Query;
         Result.Query := Result.Update.all'Access;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create the insert statement.
   --  ------------------------------
   function Create_Statement (Proxy : Update_Statement_Access) return Insert_Statement is
   begin
      return Result : Insert_Statement do
         Result.Update := Proxy.Get_Update_Query;
         Result.Query := Result.Update.all'Access;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

end ADO.Statements.Create;

-----------------------------------------------------------------------
--  ADO Statements -- Database statements
--  Copyright (C) 2009, 2010, 2011, 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.
-----------------------------------------------------------------------

package body ADO.Statements.Create is

   --  ------------------------------
   --  Create the query statement
   --  ------------------------------
   function Create_Statement (Proxy    : in Query_Statement_Access;
                              Expander : in ADO.Parameters.Expander_Access := null) return Query_Statement is
   begin
      Proxy.Set_Expander (Expander);
      Proxy.Query.Set_Expander (Expander);
      return Result : Query_Statement do
         Result.Query := Proxy.Get_Query;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create the delete statement
   --  ------------------------------
   function Create_Statement (Proxy    : in Delete_Statement_Access;
                              Expander : in ADO.Parameters.Expander_Access := null) return Delete_Statement is
   begin
      Proxy.Set_Expander (Expander);
      Proxy.Query.Set_Expander (Expander);
      return Result : Delete_Statement do
         Result.Query := Proxy.Get_Query;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Proxy    : in Update_Statement_Access;
                              Expander : in ADO.Parameters.Expander_Access := null) return Update_Statement is
   begin
      Proxy.Set_Expander (Expander);
      Proxy.Update.Set_Expander (Expander);
      return Result : Update_Statement do
         Result.Update := Proxy.Get_Update_Query;
         Result.Query := Result.Update.all'Access;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

   --  ------------------------------
   --  Create the insert statement.
   --  ------------------------------
   function Create_Statement (Proxy    : in Update_Statement_Access;
                              Expander : in ADO.Parameters.Expander_Access := null) return Insert_Statement is
   begin
      Proxy.Set_Expander (Expander);
      Proxy.Update.Set_Expander (Expander);
      return Result : Insert_Statement do
         Result.Update := Proxy.Get_Update_Query;
         Result.Query := Result.Update.all'Access;
         Result.Proxy := Proxy;
         Result.Proxy.Ref_Counter := 1;
      end return;
   end Create_Statement;

end ADO.Statements.Create;

Configure the query/proxy expander with the new parameter added to the Create_Statement operations


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012 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.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Test_Caller;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

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

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use ADO.Objects;
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : constant ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;
   end Test_Blob;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
   end Add_Tests;

end ADO.Tests;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 2009, 2010, 2011, 2012 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.Exceptions;
with Ada.Calendar;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Regtests.Images.Model;

with Util.Assertions;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;
with Util.Test_Caller;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

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

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   --  ------------------------------
   --  Test string insert.
   --  ------------------------------
   procedure Test_String (T : in out Test) is
      use ADO.Objects;
      use Ada.Strings.Unbounded;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      User : Regtests.Simple.Model.User_Ref;
      Usr2 : Regtests.Simple.Model.User_Ref;
      Name : Unbounded_String;
   begin
      for I in 1 .. 127 loop
         Append (Name, Character'Val (I));
      end loop;
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      Append (Name, ' ');
      DB.Begin_Transaction;
      User.Set_Name (Name);
      User.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Usr2.Load (DB, User.Get_Id);
      Util.Tests.Assert_Equals (T, To_String (Name), String '(Usr2.Get_Name),
                                "Invalid name inserted for user");
   end Test_String;

   --  ------------------------------
   --  Test blob insert.
   --  ------------------------------
   procedure Test_Blob (T : in out Test) is
      use ADO.Objects;
      use Ada.Streams;

      procedure Assert_Equals is
        new Util.Assertions.Assert_Equals_T (Ada.Streams.Stream_Element);

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Img  : Regtests.Images.Model.Image_Ref;
      Size : constant Natural := 100;
      Data : ADO.Blob_Ref := ADO.Create_Blob (Size);
      Img2 : Regtests.Images.Model.Image_Ref;
   begin
      for I in 1 .. Size loop
         Data.Value.Data (Ada.Streams.Stream_Element_Offset (I)) := Integer'Pos ((64 + I) mod 255);
      end loop;
      DB.Begin_Transaction;
      Img.Set_Image (Data);
      Img.Set_Create_Date (Ada.Calendar.Clock);
      Img.Save (DB);
      DB.Commit;

      --  Check that we can load the image and the blob.
      Img2.Load (DB, Img.Get_Id);
      T.Assert (Img2.Get_Image.Is_Null = False, "No image blob loaded");

      --  And verify that the blob data matches what we inserted.
      Util.Tests.Assert_Equals (T, Size, Integer (Img2.Get_Image.Value.Len),
                                "Invalid blob length");
      for I in 1 .. Data.Value.Len loop
         Assert_Equals (T, Data.Value.Data (I), Img2.Get_Image.Value.Data (I),
                        "Invalid blob content at " & Stream_Element_Offset'Image (I));
      end loop;

      --  Create a blob initialized with a file content.
      Data := ADO.Create_Blob ("Makefile");
      T.Assert (not Data.Is_Null, "Null blob returned by Create_Blob");
      T.Assert (Data.Value.Len > 100, "Blob length initialized from file is too small");
   end Test_Blob;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Object_Ref.Load", Test_Load'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save", Test_Create_Load'Access);
      Caller.Add_Test (Suite, "Test Master_Connection init error", Test_Not_Open'Access);
      Caller.Add_Test (Suite, "Test Sequences.Factory", Test_Allocate'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Save/Create/Update",
                       Test_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Object_Ref.Create (DB Insert)",
                       Test_Perf_Create_Save'Access);
      Caller.Add_Test (Suite, "Test Statement.Delete_Statement (delete all)",
                       Test_Delete_All'Access);
      Caller.Add_Test (Suite, "Test insert string",
                       Test_String'Access);
      Caller.Add_Test (Suite, "Test insert blob",
                       Test_Blob'Access);
   end Add_Tests;

end ADO.Tests;

Update unit tests to check the blob

Update unit tests to check the blob


------------------------------------------------------------------------------
-- Copyright (c) 2014-2017, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Containres provides common containers for all website-wide   --
-- persistent data.                                                         --
------------------------------------------------------------------------------

with Ada.Calendar.Time_Zones;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Streams;
with Natools.Constant_Indefinite_Ordered_Maps;
with Natools.References;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Lockable;
with Natools.Storage_Pools;

package Natools.Web.Containers is

   type Date is record
      Time : Ada.Calendar.Time;
      Offset : Ada.Calendar.Time_Zones.Time_Offset;
   end record;

   package Date_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom, Date, S_Expressions.Less_Than);

   procedure Set_Dates
     (Map : in out Date_Maps.Constant_Map;
      Date_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize date database with then given list

   package Expression_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      S_Expressions.Caches.Cursor,
      S_Expressions.Less_Than,
      S_Expressions.Caches."=");

   procedure Set_Expressions
     (Map : in out Expression_Maps.Constant_Map;
      Expression_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression database with the given list

   package Expression_Map_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      Expression_Maps.Constant_Map,
      S_Expressions.Less_Than,
      Expression_Maps."=");

   procedure Set_Expression_Maps
     (Map : in out Expression_Map_Maps.Constant_Map;
      Expression_Map_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression map database with the given list

   package Unsafe_Atom_Lists is
     new Ada.Containers.Indefinite_Doubly_Linked_Lists
        (S_Expressions.Atom, Ada.Streams."=");

   procedure Append_Atoms
     (Target : in out Unsafe_Atom_Lists.List;
      Expression : in out S_Expressions.Lockable.Descriptor'Class);

   type Atom_Array is array (S_Expressions.Count range <>)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   package Atom_Array_Refs is new References
     (Atom_Array,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create (Source : Unsafe_Atom_Lists.List)
     return Atom_Array_Refs.Immutable_Reference;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Array_Refs.Immutable_Reference;

   package Atom_Row_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Atom_Array_Refs.Immutable_Reference,
      Atom_Array_Refs."=");

   type Atom_Table is array (S_Expressions.Offset range <>)
     of Atom_Array_Refs.Immutable_Reference;

   package Atom_Table_Refs is new References
     (Atom_Table,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Table_Refs.Immutable_Reference;

   function Create
     (Row_List : in Atom_Row_Lists.List)
     return Atom_Table_Refs.Immutable_Reference;

   type Atom_Set is private;

   Null_Atom_Set : constant Atom_Set;

   function Create (Source : in Atom_Array) return Atom_Set;
   function Create (Source : in Unsafe_Atom_Lists.List) return Atom_Set;

   function Contains
     (Set : in Atom_Set;
      Value : in S_Expressions.Atom)
     return Boolean;
   function Contains
     (Set : in Atom_Set;
      Value : in String)
     return Boolean;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference;

   type Identity is record
      User : S_Expressions.Atom_Refs.Immutable_Reference;
      Groups : Atom_Set;
   end record;

   Null_Identity : constant Identity;

private

   type Atom_Set is record
      Elements : Atom_Array_Refs.Immutable_Reference;
   end record;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference
     is (Set.Elements);

   Null_Atom_Set : constant Atom_Set
     := (Elements => Atom_Array_Refs.Null_Immutable_Reference);

   Null_Identity : constant Identity
     := (User => S_Expressions.Atom_Refs.Null_Immutable_Reference,
         Groups => Null_Atom_Set);

end Natools.Web.Containers;

------------------------------------------------------------------------------
-- Copyright (c) 2014-2019, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Containres provides common containers for all website-wide   --
-- persistent data.                                                         --
------------------------------------------------------------------------------

with Ada.Calendar.Time_Zones;
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Streams;
with Natools.Constant_Indefinite_Ordered_Maps;
with Natools.References;
with Natools.S_Expressions.Atom_Refs;
with Natools.S_Expressions.Caches;
with Natools.S_Expressions.Lockable;
with Natools.Storage_Pools;

package Natools.Web.Containers is

   type Date is record
      Time : Ada.Calendar.Time;
      Offset : Ada.Calendar.Time_Zones.Time_Offset;
   end record;

   package Date_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom, Date, S_Expressions.Less_Than);

   procedure Set_Dates
     (Map : in out Date_Maps.Constant_Map;
      Date_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize date database with then given list

   package Expression_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      S_Expressions.Caches.Cursor,
      S_Expressions.Less_Than,
      S_Expressions.Caches."=");

   procedure Set_Expressions
     (Map : in out Expression_Maps.Constant_Map;
      Expression_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression database with the given list

   package Expression_Map_Maps is new Constant_Indefinite_Ordered_Maps
     (S_Expressions.Atom,
      Expression_Maps.Constant_Map,
      S_Expressions.Less_Than,
      Expression_Maps."=");

   procedure Set_Expression_Maps
     (Map : in out Expression_Map_Maps.Constant_Map;
      Expression_Map_List : in out S_Expressions.Lockable.Descriptor'Class);
      --  (Re)initialize expression map database with the given list

   type Optional_Expression (Is_Empty : Boolean := True) is record
      case Is_Empty is
         when True  => null;
         when False => Value : S_Expressions.Caches.Cursor;
      end case;
   end record;

   package Unsafe_Atom_Lists is
     new Ada.Containers.Indefinite_Doubly_Linked_Lists
        (S_Expressions.Atom, Ada.Streams."=");

   procedure Append_Atoms
     (Target : in out Unsafe_Atom_Lists.List;
      Expression : in out S_Expressions.Lockable.Descriptor'Class);

   type Atom_Array is array (S_Expressions.Count range <>)
     of S_Expressions.Atom_Refs.Immutable_Reference;

   package Atom_Array_Refs is new References
     (Atom_Array,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create (Source : Unsafe_Atom_Lists.List)
     return Atom_Array_Refs.Immutable_Reference;

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Array_Refs.Immutable_Reference;

   package Atom_Row_Lists is new Ada.Containers.Doubly_Linked_Lists
     (Atom_Array_Refs.Immutable_Reference,
      Atom_Array_Refs."=");

   type Atom_Table is array (S_Expressions.Offset range <>)
     of Atom_Array_Refs.Immutable_Reference;

   package Atom_Table_Refs is new References
     (Atom_Table,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool,
      Natools.Storage_Pools.Access_In_Default_Pool'Storage_Pool);

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Atom_Table_Refs.Immutable_Reference;

   function Create
     (Row_List : in Atom_Row_Lists.List)
     return Atom_Table_Refs.Immutable_Reference;

   type Atom_Set is private;

   Null_Atom_Set : constant Atom_Set;

   function Create (Source : in Atom_Array) return Atom_Set;
   function Create (Source : in Unsafe_Atom_Lists.List) return Atom_Set;

   function Contains
     (Set : in Atom_Set;
      Value : in S_Expressions.Atom)
     return Boolean;
   function Contains
     (Set : in Atom_Set;
      Value : in String)
     return Boolean;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference;

   type Identity is record
      User : S_Expressions.Atom_Refs.Immutable_Reference;
      Groups : Atom_Set;
   end record;

   Null_Identity : constant Identity;

private

   type Atom_Set is record
      Elements : Atom_Array_Refs.Immutable_Reference;
   end record;

   function Elements (Set : in Atom_Set)
     return Atom_Array_Refs.Immutable_Reference
     is (Set.Elements);

   Null_Atom_Set : constant Atom_Set
     := (Elements => Atom_Array_Refs.Null_Immutable_Reference);

   Null_Identity : constant Identity
     := (User => S_Expressions.Atom_Refs.Null_Immutable_Reference,
         Groups => Null_Atom_Set);

end Natools.Web.Containers;

add a type for optional expressions

containers: add a type for optional expressions