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

with Ada.Unchecked_Deallocation;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         Controller.Controllers (Phase).Execute (Context);
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Controller.Controllers (RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Exceptions;
package body ASF.Lifecycles is

   --  ------------------------------
   --  Initialize the the lifecycle handler.
   --  ------------------------------
   procedure Initialize (Controller : in out Lifecycle;
                         App        : access ASF.Applications.Main.Application'Class) is
   begin
      --  Create the phase controllers.
      Lifecycle'Class (Controller).Create_Phase_Controllers;

      --  Initialize the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Controller.Controllers (Phase).Initialize (App);
      end loop;
   end Initialize;

   --  ------------------------------
   --  Finalize the lifecycle handler, freeing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Controller : in out Lifecycle) is
      procedure Free is new Ada.Unchecked_Deallocation (Phase_Controller'Class,
                                                        Phase_Controller_Access);
   begin
      --  Free the phase controllers.
      for Phase in Controller.Controllers'Range loop
         Free (Controller.Controllers (Phase));
      end loop;
   end Finalize;

   --  ------------------------------
   --  Set the controller to be used for the given phase.
   --  ------------------------------
   procedure Set_Controller (Controller : in out Lifecycle;
                             Phase      : in Phase_Type;
                             Instance   : in Phase_Controller_Access) is
   begin
      Controller.Controllers (Phase) := Instance;
   end Set_Controller;

   --  ------------------------------
   --  Register a bundle and bind it to a facelet variable.
   --  ------------------------------
   procedure Execute (Controller : in Lifecycle;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      use type ASF.Contexts.Exceptions.Exception_Handler_Access;
   begin
      for Phase in RESTORE_VIEW .. INVOKE_APPLICATION loop
         if Context.Get_Render_Response or Context.Get_Response_Completed then
            return;
         end if;
         begin
            Controller.Controllers (Phase).Execute (Context);
         exception
            when E : others =>
               Context.Queue_Exception (E);
         end;

         --  If exceptions have been raised and queued during the current phase, process them.
         --  An exception handler could use them to redirect the current request to another
         --  page or navigate to a specific view.
         declare
            Ex : constant ASF.Contexts.Exceptions.Exception_Handler_Access
              := Context.Get_Exception_Handler;
         begin
            if Ex /= null then
               Ex.Handle;
            end if;
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Render the response by executing the response phase.
   --  ------------------------------
   procedure Render (Controller : in Lifecycle;
                     Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      Controller.Controllers (RENDER_RESPONSE).Execute (Context);
   end Render;

end ASF.Lifecycles;

Use the Exception handler - Invoke the exception handler if an ASF phase has raised/queued some exception


-----------------------------------------------------------------------
--  wiki-documents -- Wiki document
--  Copyright (C) 2011, 2015, 2016 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 Wiki.Strings;
with Wiki.Attributes;
with Wiki.Nodes;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes   : Wiki.Nodes.Node_List_Ref;
      TOC     : Wiki.Nodes.Node_List_Ref;
      Current : Wiki.Nodes.Node_Type_Access;
   end record;

end Wiki.Documents;

-----------------------------------------------------------------------
--  wiki-documents -- Wiki document
--  Copyright (C) 2011, 2015, 2016 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 Wiki.Strings;
with Wiki.Attributes;
with Wiki.Nodes;

--  === Documents ===
--  The <tt>Document</tt> type is used to hold a Wiki document that was parsed by the parser
--  with one of the supported syntax.  The <tt>Document</tt> holds two distinct parts:
--
--  * A main document body that represents the Wiki content that was parsed.
--  * A table of contents part that was built while Wiki sections are collected.
--
--  Most of the operations provided by the <tt>Wiki.Documents</tt> package are intended to
--  be used by the wiki parser and filters to build the document.  The document is made of
--  nodes whose knowledge is required by the renderer.
--
--  A document instance must be declared before parsing a text:
--
--     Doc    : Wiki.Documents.Document;
package Wiki.Documents is

   pragma Preelaborate;

   --  ------------------------------
   --  A Wiki Document
   --  ------------------------------
   type Document is tagged private;

   --  Append a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH.
   procedure Append (Into : in out Document;
                     Kind : in Wiki.Nodes.Simple_Node_Kind);

   --  Append a HTML tag start node to the document.
   procedure Push_Node (Into       : in out Document;
                        Tag        : in Html_Tag;
                        Attributes : in Wiki.Attributes.Attribute_List);

   --  Pop the HTML tag.
   procedure Pop_Node (From : in out Document;
                       Tag  : in Html_Tag);

   --  Append the text with the given format at end of the document.
   procedure Append (Into   : in out Document;
                     Text   : in Wiki.Strings.WString;
                     Format : in Format_Map);

   --  Append a section header at end of the document.
   procedure Append (Into   : in out Document;
                     Header : in Wiki.Strings.WString;
                     Level  : in Positive);

   --  Add a link.
   procedure Add_Link (Into       : in out Document;
                       Name       : in Wiki.Strings.WString;
                       Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add an image.
   procedure Add_Image (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a quote.
   procedure Add_Quote (Into       : in out Document;
                        Name       : in Wiki.Strings.WString;
                        Attributes : in out Wiki.Attributes.Attribute_List);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Into     : in out Document;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Into     : in out Document;
                             Level    : in Natural);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Into     : in out Document;
                               Text     : in Wiki.Strings.WString;
                               Format   : in Wiki.Strings.WString);

   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   procedure Iterate (Doc     : in Document;
                      Process : not null access procedure (Node : in Wiki.Nodes.Node_Type));

   --  Get the table of content node associated with the document.
   procedure Get_TOC (Doc : in out Document;
                      TOC : out Wiki.Nodes.Node_List_Ref);

   --  Get the table of content node associated with the document.
   function Get_TOC (Doc : in Document) return Wiki.Nodes.Node_List_Ref;

private

   --  Append a node to the document.
   procedure Append (Into : in out Document;
                     Node : in Wiki.Nodes.Node_Type_Access);

   type Document is tagged record
      Nodes   : Wiki.Nodes.Node_List_Ref;
      TOC     : Wiki.Nodes.Node_List_Ref;
      Current : Wiki.Nodes.Node_Type_Access;
   end record;

end Wiki.Documents;

Add some documentation

Add some documentation


with STM32.DCMI;
with STM32.DMA;     use STM32.DMA;
with Ada.Real_Time; use Ada.Real_Time;
with OV2640;        use OV2640;
with Interfaces;    use Interfaces;
with HAL.I2C;       use HAL.I2C;
with HAL.Bitmap;    use HAL.Bitmap;
with HAL;           use HAL;

package body OpenMV.Sensor is

   package DCMI renames STM32.DCMI;
   function Probe (Cam_Addr : out UInt10) return Boolean;

   REG_PID : constant := 16#0A#;
   --  REG_VER : constant := 16#0B#;

   CLK_PWM_Mod : PWM_Modulator;
   Camera      : OV2640_Cam (Sensor_I2C'Access);
   Is_Initialized : Boolean := False;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is (Is_Initialized);

   -----------
   -- Probe --
   -----------

   function Probe (Cam_Addr : out UInt10) return Boolean is
      Status : I2C_Status;
   begin
      for Addr in UInt10 range 0 .. 126 loop
         Sensor_I2C.Master_Transmit (Addr    => Addr,
                                     Data    => (0 => 0),
                                     Status  => Status,
                                     Timeout => 10_000);
         if Status = Ok then
            Cam_Addr := Addr;
            return True;
         end if;
      end loop;
      return False;
   end Probe;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      procedure Initialize_Clock;
      procedure Initialize_Camera;
      procedure Initialize_IO;
      procedure Initialize_DCMI;
      procedure Initialize_DMA;

      ----------------------
      -- Initialize_Clock --
      ----------------------

      procedure Initialize_Clock is
      begin
         Initialise_PWM_Timer (SENSOR_CLK_TIM,
                               Float (SENSOR_CLK_FREQ));

         Attach_PWM_Channel (This      => SENSOR_CLK_TIM'Access,
                             Modulator => CLK_PWM_Mod,
                             Channel   => SENSOR_CLK_CHAN,
                             Point     => SENSOR_CLK_IO,
                             PWM_AF    => SENSOR_CLK_AF);

         Set_Duty_Cycle (This    => CLK_PWM_Mod,
                         Value   => 50);
         Enable_PWM (CLK_PWM_Mod);
      end Initialize_Clock;

      -----------------------
      -- Initialize_Camera --
      -----------------------

      procedure Initialize_Camera is
         Cam_Addr : UInt10;
         Data : I2C_Data (1 .. 1);
         Status : I2C_Status;
         PID : HAL.Byte;
      begin

         --  Power cycle
         Set (DCMI_PWDN);
         delay until Clock + Milliseconds (10);
         Clear (DCMI_PWDN);
         delay until Clock + Milliseconds (10);

         Initialize_Clock;

         Set (DCMI_RST);
         delay until Clock + Milliseconds (10);
         Clear (DCMI_RST);
         delay until Clock + Milliseconds (10);

         if  not Probe (Cam_Addr) then

            --  Retry with reversed reset polarity
            Clear (DCMI_RST);
            delay until Clock + Milliseconds (10);
            Set (DCMI_RST);
            delay until Clock + Milliseconds (10);

            if  not Probe (Cam_Addr) then
               raise Program_Error;
            end if;
         end if;

         --  Select sensor bank
         Sensor_I2C.Mem_Write (Addr          => Cam_Addr,
                               Mem_Addr      => 16#FF#,
                               Mem_Addr_Size => Memory_Size_8b,
                               Data          => (0 => 1),
                               Status        => Status);
         if Status /= Ok then
            raise Program_Error;
         end if;

         Sensor_I2C.Mem_Read (Addr          => Cam_Addr,
                              Mem_Addr      => REG_PID,
                              Mem_Addr_Size => Memory_Size_8b,
                              Data          => Data,
                              Status        => Status);
         if Status /= Ok then
            raise Program_Error;
         end if;
         PID := Data (Data'First);

         if PID /= OV2640_PID then
            raise Program_Error;
         end if;

         Initialize (Camera, Cam_Addr);
         Set_Pixel_Format (Camera, Pix_RGB565);
         Set_Frame_Size (Camera, QQVGA2);
      end Initialize_Camera;

      -------------------
      -- Initialize_IO --
      -------------------

      procedure Initialize_IO is
         GPIO_Conf : GPIO_Port_Configuration;
         DCMI_AF_Points : constant GPIO_Points :=
           GPIO_Points'(DCMI_D0, DCMI_D1, DCMI_D2, DCMI_D3, DCMI_D4,
                        DCMI_D5, DCMI_D6, DCMI_D7, DCMI_VSYNC, DCMI_HSYNC,
                        DCMI_PCLK);
         DCMI_Out_Points : constant GPIO_Points :=
           GPIO_Points'(DCMI_PWDN, DCMI_RST, FS_IN);
      begin
         Enable_Clock (GPIO_Points'(Sensor_I2C_SCL, Sensor_I2C_SDA));

         GPIO_Conf.Speed       := Speed_25MHz;
         GPIO_Conf.Mode        := Mode_AF;
         GPIO_Conf.Output_Type := Open_Drain;
         GPIO_Conf.Resistors   := Floating;
         Configure_IO
           (GPIO_Points'(Sensor_I2C_SCL, Sensor_I2C_SDA), GPIO_Conf);

         Configure_Alternate_Function (Sensor_I2C_SCL, Sensor_I2C_SCL_AF);
         Configure_Alternate_Function (Sensor_I2C_SDA, Sensor_I2C_SDA_AF);

         Enable_Clock (Sensor_I2C);
         Reset (Sensor_I2C);
         Enable_Clock (Sensor_I2C);

         Configure
           (Sensor_I2C,
            (Mode                     => I2C_Mode,
             Duty_Cycle               => DutyCycle_2,
             Own_Address              => 16#00#,
             Addressing_Mode          => Addressing_Mode_7bit,
             General_Call_Enabled     => False,
             Clock_Stretching_Enabled => True,
             Clock_Speed              => 10_000));

         Enable_Clock (DCMI_Out_Points);
         --  Sensor PowerDown, Reset and FSIN
         GPIO_Conf.Mode := Mode_Out;
         GPIO_Conf.Output_Type := Push_Pull;
         GPIO_Conf.Resistors := Pull_Down;
         Configure_IO (DCMI_Out_Points, GPIO_Conf);

         Clear (DCMI_Out_Points);

         GPIO_Conf.Mode := Mode_AF;
         GPIO_Conf.Output_Type := Push_Pull;
         GPIO_Conf.Resistors := Pull_Down;
         Configure_IO (DCMI_AF_Points, GPIO_Conf);
         Configure_Alternate_Function (DCMI_AF_Points, GPIO_AF_DCMI);
      end Initialize_IO;

      ---------------------
      -- Initialize_DCMI --
      ---------------------

      procedure Initialize_DCMI is
      begin
         Enable_DCMI_Clock;
         DCMI.Configure (Data_Mode            => DCMI.DCMI_8bit,
                         Capture_Rate         => DCMI.Capture_All,
                         --  Sensor specific (OV2640)
                         Vertical_Polarity    => DCMI.Active_Low,
                         Horizontal_Polarity  => DCMI.Active_Low,
                         Pixel_Clock_Polarity => DCMI.Active_High,

                         Hardware_Sync        => True,
                         JPEG                 => False);
         DCMI.Disable_Crop;
         DCMI.Enable_DCMI;
      end Initialize_DCMI;

      --------------------
      -- Initialize_DMA --
      --------------------

      procedure Initialize_DMA is
         Config : DMA_Stream_Configuration;
      begin
         Enable_Clock (Sensor_DMA);
         Config.Channel := Sensor_DMA_Chan;
         Config.Direction := Peripheral_To_Memory;
         Config.Increment_Peripheral_Address := False;
         Config.Increment_Memory_Address := True;
         Config.Peripheral_Data_Format := Words;
         Config.Memory_Data_Format := Words;
         Config.Operation_Mode := Normal_Mode;
         Config.Priority := Priority_High;
         Config.FIFO_Enabled := True;
         Config.FIFO_Threshold := FIFO_Threshold_Full_Configuration;
         Config.Memory_Burst_Size := Memory_Burst_Inc4;
         Config.Peripheral_Burst_Size := Peripheral_Burst_Single;
         Configure (Sensor_DMA, Sensor_DMA_Stream, Config);
      end Initialize_DMA;
   begin
      Initialize_IO;
      Initialize_Camera;
      Initialize_DCMI;
      Initialize_DMA;
      Is_Initialized := True;
   end Initialize;

   --------------
   -- Snapshot --
   --------------

   procedure Snapshot (BM : HAL.Bitmap.Bitmap_Buffer'Class) is
      Status : DMA_Error_Code;
   begin
      if BM.Width /= Image_Width or else BM.Height /= Image_Height then
         raise Program_Error;
      end if;

      if not Compatible_Alignments (Sensor_DMA,
                                    Sensor_DMA_Stream,
                                    DCMI.Data_Register_Address,
                                    BM.Addr)
      then
         raise Program_Error;
      end if;

      Start_Transfer (Unit        => Sensor_DMA,
                      Stream      => Sensor_DMA_Stream,
                      Source      => DCMI.Data_Register_Address,
                      Destination => BM.Addr,
                      Data_Count  =>
                        Interfaces.Unsigned_16 ((BM.Width * BM.Height) / 2));

      DCMI.Start_Capture (DCMI.Snapshot);

      Poll_For_Completion (Sensor_DMA,
                           Sensor_DMA_Stream,
                           Full_Transfer,
                           Milliseconds (1000),
                           Status);
      if Status /= DMA_No_Error then
         Abort_Transfer (Sensor_DMA, Sensor_DMA_Stream, Status);
         pragma Unreferenced (Status);
         raise Program_Error;
      end if;
   end Snapshot;

end OpenMV.Sensor;

with STM32.DCMI;
with STM32.DMA;     use STM32.DMA;
with Ada.Real_Time; use Ada.Real_Time;
with OV2640;        use OV2640;
with Interfaces;    use Interfaces;
with HAL.I2C;       use HAL.I2C;
with HAL.Bitmap;    use HAL.Bitmap;
with HAL;           use HAL;

package body OpenMV.Sensor is

   package DCMI renames STM32.DCMI;
   function Probe (Cam_Addr : out UInt10) return Boolean;

   REG_PID : constant := 16#0A#;
   --  REG_VER : constant := 16#0B#;

   CLK_PWM_Mod : PWM_Modulator;
   Camera      : OV2640_Cam (Sensor_I2C'Access);
   Is_Initialized : Boolean := False;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is (Is_Initialized);

   -----------
   -- Probe --
   -----------

   function Probe (Cam_Addr : out UInt10) return Boolean is
      Status : I2C_Status;
   begin
      for Addr in UInt10 range 0 .. 126 loop
         Sensor_I2C.Master_Transmit (Addr    => Addr,
                                     Data    => (0 => 0),
                                     Status  => Status,
                                     Timeout => 10_000);
         if Status = Ok then
            Cam_Addr := Addr;
            return True;
         end if;
      end loop;
      return False;
   end Probe;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      procedure Initialize_Clock;
      procedure Initialize_Camera;
      procedure Initialize_IO;
      procedure Initialize_DCMI;
      procedure Initialize_DMA;

      ----------------------
      -- Initialize_Clock --
      ----------------------

      procedure Initialize_Clock is
      begin
         Initialise_PWM_Timer (SENSOR_CLK_TIM,
                               Float (SENSOR_CLK_FREQ));

         Attach_PWM_Channel (This      => SENSOR_CLK_TIM'Access,
                             Modulator => CLK_PWM_Mod,
                             Channel   => SENSOR_CLK_CHAN,
                             Point     => SENSOR_CLK_IO,
                             PWM_AF    => SENSOR_CLK_AF);

         Set_Duty_Cycle (This    => CLK_PWM_Mod,
                         Value   => 50);
         Enable_PWM (CLK_PWM_Mod);
      end Initialize_Clock;

      -----------------------
      -- Initialize_Camera --
      -----------------------

      procedure Initialize_Camera is
         Cam_Addr : UInt10;
         Data : I2C_Data (1 .. 1);
         Status : I2C_Status;
         PID : HAL.Byte;
      begin

         --  Power cycle
         Set (DCMI_PWDN);
         delay until Clock + Milliseconds (10);
         Clear (DCMI_PWDN);
         delay until Clock + Milliseconds (10);

         Initialize_Clock;

         Set (DCMI_RST);
         delay until Clock + Milliseconds (10);
         Clear (DCMI_RST);
         delay until Clock + Milliseconds (10);

         if  not Probe (Cam_Addr) then

            --  Retry with reversed reset polarity
            Clear (DCMI_RST);
            delay until Clock + Milliseconds (10);
            Set (DCMI_RST);
            delay until Clock + Milliseconds (10);

            if  not Probe (Cam_Addr) then
               raise Program_Error;
            end if;
         end if;

         --  Select sensor bank
         Sensor_I2C.Mem_Write (Addr          => Cam_Addr,
                               Mem_Addr      => 16#FF#,
                               Mem_Addr_Size => Memory_Size_8b,
                               Data          => (0 => 1),
                               Status        => Status);
         if Status /= Ok then
            raise Program_Error;
         end if;

         Sensor_I2C.Mem_Read (Addr          => Cam_Addr,
                              Mem_Addr      => REG_PID,
                              Mem_Addr_Size => Memory_Size_8b,
                              Data          => Data,
                              Status        => Status);
         if Status /= Ok then
            raise Program_Error;
         end if;
         PID := Data (Data'First);

         if PID /= OV2640_PID then
            raise Program_Error;
         end if;

         Initialize (Camera, Cam_Addr);
         Set_Pixel_Format (Camera, Pix_RGB565);
         Set_Frame_Size (Camera, QQVGA2);
      end Initialize_Camera;

      -------------------
      -- Initialize_IO --
      -------------------

      procedure Initialize_IO is
         GPIO_Conf : GPIO_Port_Configuration;
         DCMI_AF_Points : constant GPIO_Points :=
           GPIO_Points'(DCMI_D0, DCMI_D1, DCMI_D2, DCMI_D3, DCMI_D4,
                        DCMI_D5, DCMI_D6, DCMI_D7, DCMI_VSYNC, DCMI_HSYNC,
                        DCMI_PCLK);
         DCMI_Out_Points : GPIO_Points :=
           GPIO_Points'(DCMI_PWDN, DCMI_RST, FS_IN);
      begin
         Enable_Clock (GPIO_Points'(Sensor_I2C_SCL, Sensor_I2C_SDA));

         GPIO_Conf.Speed       := Speed_25MHz;
         GPIO_Conf.Mode        := Mode_AF;
         GPIO_Conf.Output_Type := Open_Drain;
         GPIO_Conf.Resistors   := Floating;
         Configure_IO
           (GPIO_Points'(Sensor_I2C_SCL, Sensor_I2C_SDA), GPIO_Conf);

         Configure_Alternate_Function (Sensor_I2C_SCL, Sensor_I2C_SCL_AF);
         Configure_Alternate_Function (Sensor_I2C_SDA, Sensor_I2C_SDA_AF);

         Enable_Clock (Sensor_I2C);
         Reset (Sensor_I2C);
         Enable_Clock (Sensor_I2C);

         Configure
           (Sensor_I2C,
            (Mode                     => I2C_Mode,
             Duty_Cycle               => DutyCycle_2,
             Own_Address              => 16#00#,
             Addressing_Mode          => Addressing_Mode_7bit,
             General_Call_Enabled     => False,
             Clock_Stretching_Enabled => True,
             Clock_Speed              => 10_000));

         Enable_Clock (DCMI_Out_Points);
         --  Sensor PowerDown, Reset and FSIN
         GPIO_Conf.Mode := Mode_Out;
         GPIO_Conf.Output_Type := Push_Pull;
         GPIO_Conf.Resistors := Pull_Down;
         Configure_IO (DCMI_Out_Points, GPIO_Conf);

         Clear (DCMI_Out_Points);

         GPIO_Conf.Mode := Mode_AF;
         GPIO_Conf.Output_Type := Push_Pull;
         GPIO_Conf.Resistors := Pull_Down;
         Configure_IO (DCMI_AF_Points, GPIO_Conf);
         Configure_Alternate_Function (DCMI_AF_Points, GPIO_AF_DCMI);
      end Initialize_IO;

      ---------------------
      -- Initialize_DCMI --
      ---------------------

      procedure Initialize_DCMI is
      begin
         Enable_DCMI_Clock;
         DCMI.Configure (Data_Mode            => DCMI.DCMI_8bit,
                         Capture_Rate         => DCMI.Capture_All,
                         --  Sensor specific (OV2640)
                         Vertical_Polarity    => DCMI.Active_Low,
                         Horizontal_Polarity  => DCMI.Active_Low,
                         Pixel_Clock_Polarity => DCMI.Active_High,

                         Hardware_Sync        => True,
                         JPEG                 => False);
         DCMI.Disable_Crop;
         DCMI.Enable_DCMI;
      end Initialize_DCMI;

      --------------------
      -- Initialize_DMA --
      --------------------

      procedure Initialize_DMA is
         Config : DMA_Stream_Configuration;
      begin
         Enable_Clock (Sensor_DMA);
         Config.Channel := Sensor_DMA_Chan;
         Config.Direction := Peripheral_To_Memory;
         Config.Increment_Peripheral_Address := False;
         Config.Increment_Memory_Address := True;
         Config.Peripheral_Data_Format := Words;
         Config.Memory_Data_Format := Words;
         Config.Operation_Mode := Normal_Mode;
         Config.Priority := Priority_High;
         Config.FIFO_Enabled := True;
         Config.FIFO_Threshold := FIFO_Threshold_Full_Configuration;
         Config.Memory_Burst_Size := Memory_Burst_Inc4;
         Config.Peripheral_Burst_Size := Peripheral_Burst_Single;
         Configure (Sensor_DMA, Sensor_DMA_Stream, Config);
      end Initialize_DMA;
   begin
      Initialize_IO;
      Initialize_Camera;
      Initialize_DCMI;
      Initialize_DMA;
      Is_Initialized := True;
   end Initialize;

   --------------
   -- Snapshot --
   --------------

   procedure Snapshot (BM : HAL.Bitmap.Bitmap_Buffer'Class) is
      Status : DMA_Error_Code;
   begin
      if BM.Width /= Image_Width or else BM.Height /= Image_Height then
         raise Program_Error;
      end if;

      if not Compatible_Alignments (Sensor_DMA,
                                    Sensor_DMA_Stream,
                                    DCMI.Data_Register_Address,
                                    BM.Addr)
      then
         raise Program_Error;
      end if;

      Start_Transfer (Unit        => Sensor_DMA,
                      Stream      => Sensor_DMA_Stream,
                      Source      => DCMI.Data_Register_Address,
                      Destination => BM.Addr,
                      Data_Count  =>
                        Interfaces.Unsigned_16 ((BM.Width * BM.Height) / 2));

      DCMI.Start_Capture (DCMI.Snapshot);

      Poll_For_Completion (Sensor_DMA,
                           Sensor_DMA_Stream,
                           Full_Transfer,
                           Milliseconds (1000),
                           Status);
      if Status /= DMA_No_Error then
         Abort_Transfer (Sensor_DMA, Sensor_DMA_Stream, Status);
         pragma Unreferenced (Status);
         raise Program_Error;
      end if;
   end Snapshot;

end OpenMV.Sensor;

Fix erroneous constant GPIO

OpenMV: Fix erroneous constant GPIO


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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         --  Storing a date in the database will loose some precision.
         T.Assert (S1.Get_Start_Date.Value >= T1 - 1.0, "Start date is invalid 1");
         T.Assert (S1.Get_Start_Date.Value >= T2 - 1.0, "Start date is invalid 2");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         --  Storing a date in the database will loose some precision.
         T.Assert (S1.Get_Start_Date.Value >= T1 - 1.0, "Start date is invalid 1");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

Fix unit test execution due to date issues


-----------------------------------------------------------------------
--  asf-lifecycles-tests -  Tests for ASF lifecycles
--  Copyright (C) 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.Unchecked_Deallocation;

with Util.Test_Caller;
with Util.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Tests;
package body ASF.Lifecycles.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test lifecycle (get)",
                       Test_Get_Lifecycle'Access);
      Caller.Add_Test (Suite, "Test lifecycle (postback)",
                       Test_Post_Lifecycle'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Test a GET request and the lifecycles that this implies.
   --  ------------------------------
   procedure Test_Get_Lifecycle (T : in out Test) is
      use ASF.Events.Phases;

      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      Listener : aliased Test_Phase_Listener;
      Handler  : constant Lifecycle_Access := ASF.Tests.Get_Application.Get_Lifecycle_Handler;
   begin
      Handler.Add_Phase_Listener (Listener'Unchecked_Access);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/form-text.html", "form-text.txt");

      Listener.Check_Get_Counters (T, 1);
      Listener.Check_Post_Counters (T, 0);

      Handler.Remove_Phase_Listener (Listener'Unchecked_Access);

   exception
      when others =>
         Handler.Remove_Phase_Listener (Listener'Unchecked_Access);
         raise;
   end Test_Get_Lifecycle;

   --  ------------------------------
   --  Test a GET+POST request with submitted values and an action method called on the bean.
   --  ------------------------------
   procedure Test_Post_Lifecycle (T : in out Test) is

      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      Listener : aliased Test_Phase_Listener;
      Handler  : constant Lifecycle_Access := ASF.Tests.Get_Application.Get_Lifecycle_Handler;
   begin
      Handler.Add_Phase_Listener (Listener'Unchecked_Access);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/form-text.html", "form-text.txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/form-text.html", "form-text-post.txt");

      Listener.Check_Post_Counters (T, 1);
      Listener.Check_Get_Counters (T, 2);

      Handler.Remove_Phase_Listener (Listener'Unchecked_Access);

   exception
      when others =>
         Handler.Remove_Phase_Listener (Listener'Unchecked_Access);
         raise;
   end Test_Post_Lifecycle;

   --  ------------------------------
   --  Check that the RESTORE_VIEW and RENDER_RESPONSE counters have the given value.
   --  ------------------------------
   procedure Check_Get_Counters (Listener : in Test_Phase_Listener;
                                 T        : in out Test'Class;
                                 Value    : in Natural) is
      use ASF.Events.Phases;
   begin
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (RESTORE_VIEW),
                                "Invalid before RESTORE_VIEW count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (RESTORE_VIEW),
                                "Invalid after RESTORE_VIEW count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (RENDER_RESPONSE),
                                "Invalid before RENDER_RESPONSE count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (RENDER_RESPONSE),
                                "Invalid after RENDER_RESPONSE count");
   end Check_Get_Counters;

   --  ------------------------------
   --  Check that the APPLY_REQUESTS .. INVOKE_APPLICATION counters have the given value.
   --  ------------------------------
   procedure Check_Post_Counters (Listener : in Test_Phase_Listener;
                                  T        : in out Test'Class;
                                  Value    : in Natural) is
      use ASF.Events.Phases;
   begin
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (APPLY_REQUEST_VALUES),
                                "Invalid before APPLY_REQUEST_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (APPLY_REQUEST_VALUES),
                                "Invalid after APPLY_REQUEST_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (PROCESS_VALIDATION),
                                "Invalid before PROCESS_VALIDATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (PROCESS_VALIDATION),
                                "Invalid after PROCESS_VALIDATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (UPDATE_MODEL_VALUES),
                                "Invalid before UPDATE_MODEL_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (UPDATE_MODEL_VALUES),
                                "Invalid after UPDATE_MODEL_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (INVOKE_APPLICATION),
                                "Invalid before INVOKE_APPLICATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (INVOKE_APPLICATION),
                                "Invalid after INVOKE_APPLICATION count");
   end Check_Post_Counters;

   --  ------------------------------
   --  Notifies that the lifecycle phase described by the event is about to begin.
   --  ------------------------------
   procedure Before_Phase (Listener : in Test_Phase_Listener;
                           Event    : in ASF.Events.Phases.Phase_Event'Class) is
   begin
      Listener.Before_Count (Event.Phase) := Listener.Before_Count (Event.Phase) + 1;
   end Before_Phase;

   --  ------------------------------
   --  Notifies that the lifecycle phase described by the event has finished.
   --  ------------------------------
   procedure After_Phase (Listener : in Test_Phase_Listener;
                          Event    : in ASF.Events.Phases.Phase_Event'Class) is
   begin
      Listener.After_Count (Event.Phase) := Listener.After_Count (Event.Phase) + 1;
   end After_Phase;

   --  ------------------------------
   --  Return the phase that this listener is interested in processing the Phase_Event
   --  events.  If the listener is interested by several events, it should return ANY_PHASE.
   --  ------------------------------
   function Get_Phase (Listener : in Test_Phase_Listener) return ASF.Events.Phases.Phase_Type is
   begin
      return Listener.Phase;
   end Get_Phase;

   overriding
   procedure Initialize (Listener : in out Test_Phase_Listener) is
   begin
      Listener.After_Count := new Phase_Counters '(others => 0);
      Listener.Before_Count := new Phase_Counters '(others => 0);
   end Initialize;

   overriding
   procedure Finalize (Listener : in out Test_Phase_Listener) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Phase_Counters,
                                         Name   => Phase_Counters_Array);
   begin
      Free (Listener.After_Count);
      Free (Listener.Before_Count);
   end Finalize;

end ASF.Lifecycles.Tests;

-----------------------------------------------------------------------
--  asf-lifecycles-tests -  Tests for ASF lifecycles
--  Copyright (C) 2012, 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 Ada.Unchecked_Deallocation;

with Util.Test_Caller;
with Util.Beans.Objects;

with ASF.Tests;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Applications.Main;
with ASF.Applications.Tests;
package body ASF.Lifecycles.Tests is

   use Util.Beans.Objects;
   use ASF.Tests;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test lifecycle (get)",
                       Test_Get_Lifecycle'Access);
      Caller.Add_Test (Suite, "Test lifecycle (postback)",
                       Test_Post_Lifecycle'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   overriding
   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);

      use type ASF.Applications.Main.Application_Access;
      Fact     : ASF.Applications.Main.Application_Factory;
   begin
      if ASF.Tests.Get_Application = null then
         ASF.Tests.Initialize (Util.Tests.Get_Properties, Factory => Fact);
      end if;
   end Set_Up;

   --  ------------------------------
   --  Test a GET request and the lifecycles that this implies.
   --  ------------------------------
   procedure Test_Get_Lifecycle (T : in out Test) is
      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      Listener : aliased Test_Phase_Listener;
      Handler  : constant Lifecycle_Access := ASF.Tests.Get_Application.Get_Lifecycle_Handler;
   begin
      Handler.Add_Phase_Listener (Listener'Unchecked_Access);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/form-text.html", "form-text.txt");

      Listener.Check_Get_Counters (T, 1);
      Listener.Check_Post_Counters (T, 0);

      Handler.Remove_Phase_Listener (Listener'Unchecked_Access);

   exception
      when others =>
         Handler.Remove_Phase_Listener (Listener'Unchecked_Access);
         raise;
   end Test_Get_Lifecycle;

   --  ------------------------------
   --  Test a GET+POST request with submitted values and an action method called on the bean.
   --  ------------------------------
   procedure Test_Post_Lifecycle (T : in out Test) is

      Request  : ASF.Requests.Mockup.Request;
      Reply    : ASF.Responses.Mockup.Response;
      Form     : aliased ASF.Applications.Tests.Form_Bean;
      Listener : aliased Test_Phase_Listener;
      Handler  : constant Lifecycle_Access := ASF.Tests.Get_Application.Get_Lifecycle_Handler;
   begin
      Handler.Add_Phase_Listener (Listener'Unchecked_Access);
      Request.Set_Attribute ("form", To_Object (Value   => Form'Unchecked_Access,
                                                Storage => STATIC));
      Do_Get (Request, Reply, "/tests/form-text.html", "form-text.txt");

      Request.Set_Parameter ("formText", "1");
      Request.Set_Parameter ("name", "John");
      Request.Set_Parameter ("password", "12345");
      Request.Set_Parameter ("email", "john@gmail.com");
      Request.Set_Parameter ("ok", "1");
      Do_Post (Request, Reply, "/tests/form-text.html", "form-text-post.txt");

      Listener.Check_Post_Counters (T, 1);
      Listener.Check_Get_Counters (T, 2);

      Handler.Remove_Phase_Listener (Listener'Unchecked_Access);

   exception
      when others =>
         Handler.Remove_Phase_Listener (Listener'Unchecked_Access);
         raise;
   end Test_Post_Lifecycle;

   --  ------------------------------
   --  Check that the RESTORE_VIEW and RENDER_RESPONSE counters have the given value.
   --  ------------------------------
   procedure Check_Get_Counters (Listener : in Test_Phase_Listener;
                                 T        : in out Test'Class;
                                 Value    : in Natural) is
      use ASF.Events.Phases;
   begin
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (RESTORE_VIEW),
                                "Invalid before RESTORE_VIEW count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (RESTORE_VIEW),
                                "Invalid after RESTORE_VIEW count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (RENDER_RESPONSE),
                                "Invalid before RENDER_RESPONSE count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (RENDER_RESPONSE),
                                "Invalid after RENDER_RESPONSE count");
   end Check_Get_Counters;

   --  ------------------------------
   --  Check that the APPLY_REQUESTS .. INVOKE_APPLICATION counters have the given value.
   --  ------------------------------
   procedure Check_Post_Counters (Listener : in Test_Phase_Listener;
                                  T        : in out Test'Class;
                                  Value    : in Natural) is
      use ASF.Events.Phases;
   begin
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (APPLY_REQUEST_VALUES),
                                "Invalid before APPLY_REQUEST_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (APPLY_REQUEST_VALUES),
                                "Invalid after APPLY_REQUEST_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (PROCESS_VALIDATION),
                                "Invalid before PROCESS_VALIDATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (PROCESS_VALIDATION),
                                "Invalid after PROCESS_VALIDATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (UPDATE_MODEL_VALUES),
                                "Invalid before UPDATE_MODEL_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (UPDATE_MODEL_VALUES),
                                "Invalid after UPDATE_MODEL_VALUES count");
      Util.Tests.Assert_Equals (T, Value, Listener.Before_Count (INVOKE_APPLICATION),
                                "Invalid before INVOKE_APPLICATION count");
      Util.Tests.Assert_Equals (T, Value, Listener.After_Count (INVOKE_APPLICATION),
                                "Invalid after INVOKE_APPLICATION count");
   end Check_Post_Counters;

   --  ------------------------------
   --  Notifies that the lifecycle phase described by the event is about to begin.
   --  ------------------------------
   procedure Before_Phase (Listener : in Test_Phase_Listener;
                           Event    : in ASF.Events.Phases.Phase_Event'Class) is
   begin
      Listener.Before_Count (Event.Phase) := Listener.Before_Count (Event.Phase) + 1;
   end Before_Phase;

   --  ------------------------------
   --  Notifies that the lifecycle phase described by the event has finished.
   --  ------------------------------
   procedure After_Phase (Listener : in Test_Phase_Listener;
                          Event    : in ASF.Events.Phases.Phase_Event'Class) is
   begin
      Listener.After_Count (Event.Phase) := Listener.After_Count (Event.Phase) + 1;
   end After_Phase;

   --  ------------------------------
   --  Return the phase that this listener is interested in processing the Phase_Event
   --  events.  If the listener is interested by several events, it should return ANY_PHASE.
   --  ------------------------------
   function Get_Phase (Listener : in Test_Phase_Listener) return ASF.Events.Phases.Phase_Type is
   begin
      return Listener.Phase;
   end Get_Phase;

   overriding
   procedure Initialize (Listener : in out Test_Phase_Listener) is
   begin
      Listener.After_Count := new Phase_Counters '(others => 0);
      Listener.Before_Count := new Phase_Counters '(others => 0);
   end Initialize;

   overriding
   procedure Finalize (Listener : in out Test_Phase_Listener) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Phase_Counters,
                                         Name   => Phase_Counters_Array);
   begin
      Free (Listener.After_Count);
      Free (Listener.Before_Count);
   end Finalize;

end ASF.Lifecycles.Tests;

Remove unused use clauses

Remove unused use clauses


--  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 Wayland.Cursor;
private with Wayland.EGL;
private with Wayland.Protocols.Xdg_Shell;
private with Wayland.Protocols.Presentation_Time;
private with Wayland.Protocols.Idle_Inhibit_Unstable_V1;
private with Wayland.Protocols.Xdg_Decoration_Unstable_V1;
private with Wayland.Protocols.Pointer_Constraints_Unstable_V1;

private with EGL.Objects.Displays;
private with EGL.Objects.Surfaces;

with Wayland.Protocols.Client;

with EGL.Objects.Configs;
with EGL.Objects.Contexts;

with AWT.Inputs;
with AWT.Monitors;
with AWT.Windows;

package AWT.Wayland.Windows is
   pragma Preelaborate;

   type Wayland_Window is abstract limited new AWT.Windows.Window with private;

   procedure Sleep_Until_Swap
     (Object       : in out Wayland_Window;
      Time_To_Swap : Duration) is abstract;

   ----------------------------------------------------------------------------
   --                          Internal Subprograms                          --
   ----------------------------------------------------------------------------

   procedure Set_State
     (Object : in out Wayland_Window;
      State  : AWT.Inputs.Pointer_State);

   procedure Set_State
     (Object : in out Wayland_Window;
      State  : AWT.Inputs.Keyboard_State);

   procedure Update_Cursor (Object : in out Wayland_Window) is null;

   procedure Restore_Cursor (Object : in out Wayland_Window);

   type Surface_With_Window (Window : not null access Wayland_Window)
     is new WP.Client.Surface with null record;

   procedure Update_Animated_Cursor (Window : not null access Wayland_Window);

   procedure Set_EGL_Data
     (Object  : in out Wayland_Window;
      Context : EGL.Objects.Contexts.Context;
      Config  : EGL.Objects.Configs.Config;
      sRGB    : Boolean);

   procedure Make_Current
     (Object  : in out Wayland_Window;
      Context : Standard.EGL.Objects.Contexts.Context);

private

   package SU renames Ada.Strings.Unbounded;

   package II renames WP.Idle_Inhibit_Unstable_V1;
   package XD renames WP.Xdg_Decoration_Unstable_V1;
   package PC renames WP.Pointer_Constraints_Unstable_V1;
   package WC renames Standard.Wayland.Cursor;

   subtype Unsigned_32 is Standard.Wayland.Unsigned_32;

   type Xdg_Surface_With_Window (Window : not null access Wayland_Window)
     is new WP.Xdg_Shell.Xdg_Surface with null record;

   type Xdg_Toplevel_With_Window (Window : not null access Wayland_Window)
     is new WP.Xdg_Shell.Xdg_Toplevel with null record;

   type Toplevel_Decoration_With_Window (Window : not null access Wayland_Window)
     is new XD.Toplevel_Decoration_V1 with null record;

   type Locked_Pointer_With_Window (Window : not null access Wayland_Window)
     is new PC.Locked_Pointer_V1 with null record;

   type Frame;

   type Feedback_With_Frame (Data : not null access Frame)
     is new WP.Presentation_Time.Presentation_Feedback with null record;

   type Frame_Index is mod 16;

   type Frame is limited record
      Window      : access Wayland_Window;
      Feedback    : Feedback_With_Frame (Frame'Access);
      Index       : Frame_Index;
      Start, Stop : Duration := 0.0;
   end record;

   type Frame_Array is array (Frame_Index) of Frame;

   function Make_Frames (Window : not null access Wayland_Window) return Frame_Array
     with Post => (for all FB of Make_Frames'Result => FB.Window /= null);

   protected type Frame_Handler_With_Window (Window : not null access Wayland_Window) is
      entry Before_Swap_Buffers (Time_To_Swap : out Duration; Do_Swap : out Boolean);
      procedure After_Swap_Buffers;

      procedure On_Frame_Output (Index : Frame_Index; Refresh : Duration);
      procedure On_Frame_Presented (Index : Frame_Index; Timestamp, Refresh : Duration);
      procedure On_Frame_Discarded (Index : Frame_Index);

      procedure Set_Size
        (Width, Height : Positive;
         Margin        : Natural;
         Serial        : Unsigned_32);

      entry Set_Has_Buffer (Value : Boolean);

      procedure Finalize;
   private
      Max_In_Flight   : Duration := 0.0;
      Latest_Stop     : Duration := 0.0;
      Default_Refresh : Duration := 0.0;

      Resize_Width, Resize_Height, Resize_Margin : Natural := 0;
      Resize_Serial : Unsigned_32;

      Has_Buffer : Boolean := False;
      Swapping   : Boolean := False;

      Pending : Natural := 0;
      Frames  : Frame_Array := Make_Frames (Window);
   end Frame_Handler_With_Window;

   type Cursor_Hotspot_Coordinate is array (AWT.Inputs.Dimension) of Natural;

   type Wayland_Window is
     abstract limited new Ada.Finalization.Limited_Controlled and AWT.Windows.Window with
   record
      Pending_State, Current_State : AWT.Windows.Window_State;
      Pending_Scale, Current_Scale : Positive := 1;

      Restore_Width  : Natural := 0;
      Restore_Height : Natural := 0;
      Restore_Margin : Natural := 0;
      Restore_ID     : SU.Unbounded_String;
      Restore_Title  : SU.Unbounded_String;

      Initial_Configure : Boolean := True;

      Surface : Surface_With_Window (Wayland_Window'Access);

      XDG_Surface  : Xdg_Surface_With_Window (Wayland_Window'Access);
      XDG_Toplevel : Xdg_Toplevel_With_Window (Wayland_Window'Access);

      Decoration   : Toplevel_Decoration_With_Window (Wayland_Window'Access);

      Frame_Handler : Frame_Handler_With_Window (Wayland_Window'Access);

      --  Wayland.EGL
      EGL_Window  : Standard.Wayland.EGL.Window;

      --  EGL
      EGL_Surface : EGL.Objects.Surfaces.Surface (EGL.Objects.Displays.Wayland);
      EGL_Context : EGL.Objects.Contexts.Context (EGL.Objects.Displays.Wayland);
      EGL_Config  : EGL.Objects.Configs.Config;
      EGL_sRGB    : Boolean;

      Should_Close : Boolean := False with Atomic;

      Idle_Inhibitor : II.Idle_Inhibitor_V1;

      Pointer_State  : AWT.Inputs.Pointer_State;
      Keyboard_State : AWT.Inputs.Keyboard_State;

      Locked_Pointer        : Locked_Pointer_With_Window (Wayland_Window'Access);
      Locked_Position       : AWT.Inputs.Coordinate;
      Unlocked_Pointer_Mode : AWT.Inputs.Pointer_Mode;
      Raw_Pointer_Motion    : Boolean := False;

      Cursor_Surface : WP.Client.Surface;
      Cursor_Hotspot : Cursor_Hotspot_Coordinate := (others => 0);
      Cursor         : AWT.Inputs.Cursors.Pointer_Cursor := AWT.Inputs.Cursors.Default;
      Cursor_Images  : Positive := 1;
   end record;

   overriding
   procedure Create_Window
     (Object                        : aliased in out Wayland_Window;
      ID, Title                     : String;
      Width, Height                 : Positive;
      Visible, Resizable, Decorated : Boolean := True;
      Transparent                   : Boolean := False);

   overriding procedure Finalize (Object : in out Wayland_Window);

   overriding
   procedure Set_Application_ID (Object : in out Wayland_Window; ID : String);

   overriding
   procedure Set_Application_Title (Object : in out Wayland_Window; Title : String);

   overriding
   procedure Set_Size (Object : in out Wayland_Window; Width, Height : Positive);

   overriding
   procedure Set_Size_Limits
     (Object : in out Wayland_Window;
      Min_Width, Min_Height, Max_Width, Max_Height : Natural);

   overriding
   procedure Set_Size_Mode (Object : in out Wayland_Window; Mode : AWT.Windows.Size_Mode);

   overriding
   procedure Set_Size_Mode
     (Object  : in out Wayland_Window;
      Mode    : AWT.Windows.Size_Mode;
      Monitor : AWT.Monitors.Monitor'Class);

   overriding
   procedure Set_Framebuffer_Scale (Object : in out Wayland_Window; Scale : Positive);

   overriding
   procedure Set_Raw_Pointer_Motion (Object : in out Wayland_Window; Enable : Boolean);

   overriding
   procedure Set_Margin
     (Object : in out Wayland_Window;
      Margin : Natural);

   overriding
   procedure Set_Visible (Object : in out Wayland_Window; Visible : Boolean);

   overriding
   procedure Set_Pointer_Cursor
     (Object : in out Wayland_Window;
      Cursor : AWT.Inputs.Cursors.Pointer_Cursor);

   overriding
   procedure Set_Pointer_Mode
     (Object : in out Wayland_Window;
      Mode   : AWT.Inputs.Pointer_Mode);

   overriding
   function Raw_Pointer_Motion (Object : Wayland_Window) return Boolean;

   overriding
   function State (Object : Wayland_Window) return AWT.Windows.Window_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Windows.Framebuffer_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Inputs.Pointer_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Inputs.Keyboard_State;

   overriding
   procedure Close (Object : in out Wayland_Window);

   overriding
   function Should_Close (Object : Wayland_Window) return Boolean;

   overriding
   procedure Swap_Buffers (Object : in out Wayland_Window);

   overriding
   procedure Set_Vertical_Sync (Object : in out Wayland_Window; Enable : Boolean);

   overriding
   function On_Close (Object : Wayland_Window) return Boolean;

   function On_Change_Cursor
     (Object : in out Wayland_Window;
      Name   : AWT.Inputs.Cursors.Pointer_Cursor;
      Cursor : WC.Cursor'Class) return WC.Cursor_Image'Class;

end AWT.Wayland.Windows;

--  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 Wayland.Cursor;
private with Wayland.EGL;
private with Wayland.Protocols.Xdg_Shell;
private with Wayland.Protocols.Presentation_Time;
private with Wayland.Protocols.Idle_Inhibit_Unstable_V1;
private with Wayland.Protocols.Xdg_Decoration_Unstable_V1;
private with Wayland.Protocols.Pointer_Constraints_Unstable_V1;

private with EGL.Objects.Displays;
private with EGL.Objects.Surfaces;

with Wayland.Protocols.Client;

with EGL.Objects.Configs;
with EGL.Objects.Contexts;

with AWT.Inputs;
with AWT.Monitors;
with AWT.Windows;

--  To display a window on the screen via Wayland quite a few objects
--  are needed:
--
--  - Objects wl_compositor and xdg_wm_base are globals that are binded
--  in package AWT.Registry.
--
--  - Objects xdg_surface and xdg_toplevel are objects from the xdg-shell
--  protocol that will cause the compositor to eventually display a window
--  (the wl_surface object) on the screen.
--
--  - Object wl_egl_window is created via the libwayland-egl library and
--  is used to get an EGLSurface, which is attached to an EGLContext for
--  use by eglSwapBuffers(). When this function is called, it attaches a
--  buffer (the default framebuffer) to the wl_surface and then commits
--  this surface.
--
--   wl_display
--       |
--       v
--  wl_registry
--       |  \
--       |   -> wl_compositor
--       |            |
--       v            v
--  xdg_wm_base + wl_surface
--              |           \
--              v            -> wl_egl_window
--         xdg_surface                |
--              |                     v
--              v                 EGLSurface (via eglCreatePlatformWindowSurfaceEXT())
--         xdg_toplevel               |
--                                    v
--                     attach EGLSurface to EGLContext
--                          with eglMakeCurrent()

package AWT.Wayland.Windows is
   pragma Preelaborate;

   type Wayland_Window is abstract limited new AWT.Windows.Window with private;

   procedure Sleep_Until_Swap
     (Object       : in out Wayland_Window;
      Time_To_Swap : Duration) is abstract;

   ----------------------------------------------------------------------------
   --                          Internal Subprograms                          --
   ----------------------------------------------------------------------------

   procedure Set_State
     (Object : in out Wayland_Window;
      State  : AWT.Inputs.Pointer_State);

   procedure Set_State
     (Object : in out Wayland_Window;
      State  : AWT.Inputs.Keyboard_State);

   procedure Update_Cursor (Object : in out Wayland_Window) is null;

   procedure Restore_Cursor (Object : in out Wayland_Window);

   type Surface_With_Window (Window : not null access Wayland_Window)
     is new WP.Client.Surface with null record;

   procedure Update_Animated_Cursor (Window : not null access Wayland_Window);

   procedure Set_EGL_Data
     (Object  : in out Wayland_Window;
      Context : EGL.Objects.Contexts.Context;
      Config  : EGL.Objects.Configs.Config;
      sRGB    : Boolean);

   procedure Make_Current
     (Object  : in out Wayland_Window;
      Context : Standard.EGL.Objects.Contexts.Context);

private

   package SU renames Ada.Strings.Unbounded;

   package II renames WP.Idle_Inhibit_Unstable_V1;
   package XD renames WP.Xdg_Decoration_Unstable_V1;
   package PC renames WP.Pointer_Constraints_Unstable_V1;
   package WC renames Standard.Wayland.Cursor;

   subtype Unsigned_32 is Standard.Wayland.Unsigned_32;

   type Xdg_Surface_With_Window (Window : not null access Wayland_Window)
     is new WP.Xdg_Shell.Xdg_Surface with null record;

   type Xdg_Toplevel_With_Window (Window : not null access Wayland_Window)
     is new WP.Xdg_Shell.Xdg_Toplevel with null record;

   type Toplevel_Decoration_With_Window (Window : not null access Wayland_Window)
     is new XD.Toplevel_Decoration_V1 with null record;

   type Locked_Pointer_With_Window (Window : not null access Wayland_Window)
     is new PC.Locked_Pointer_V1 with null record;

   type Frame;

   type Feedback_With_Frame (Data : not null access Frame)
     is new WP.Presentation_Time.Presentation_Feedback with null record;

   type Frame_Index is mod 16;

   type Frame is limited record
      Window      : access Wayland_Window;
      Feedback    : Feedback_With_Frame (Frame'Access);
      Index       : Frame_Index;
      Start, Stop : Duration := 0.0;
   end record;

   type Frame_Array is array (Frame_Index) of Frame;

   function Make_Frames (Window : not null access Wayland_Window) return Frame_Array
     with Post => (for all FB of Make_Frames'Result => FB.Window /= null);

   protected type Frame_Handler_With_Window (Window : not null access Wayland_Window) is
      entry Before_Swap_Buffers (Time_To_Swap : out Duration; Do_Swap : out Boolean);
      procedure After_Swap_Buffers;

      procedure On_Frame_Output (Index : Frame_Index; Refresh : Duration);
      procedure On_Frame_Presented (Index : Frame_Index; Timestamp, Refresh : Duration);
      procedure On_Frame_Discarded (Index : Frame_Index);

      procedure Set_Size
        (Width, Height : Positive;
         Margin        : Natural;
         Serial        : Unsigned_32);

      entry Set_Has_Buffer (Value : Boolean);

      procedure Finalize;
   private
      Max_In_Flight   : Duration := 0.0;
      Latest_Stop     : Duration := 0.0;
      Default_Refresh : Duration := 0.0;

      Resize_Width, Resize_Height, Resize_Margin : Natural := 0;
      Resize_Serial : Unsigned_32;

      Has_Buffer : Boolean := False;
      Swapping   : Boolean := False;

      Pending : Natural := 0;
      Frames  : Frame_Array := Make_Frames (Window);
   end Frame_Handler_With_Window;

   type Cursor_Hotspot_Coordinate is array (AWT.Inputs.Dimension) of Natural;

   type Wayland_Window is
     abstract limited new Ada.Finalization.Limited_Controlled and AWT.Windows.Window with
   record
      Pending_State, Current_State : AWT.Windows.Window_State;
      Pending_Scale, Current_Scale : Positive := 1;

      Restore_Width  : Natural := 0;
      Restore_Height : Natural := 0;
      Restore_Margin : Natural := 0;
      Restore_ID     : SU.Unbounded_String;
      Restore_Title  : SU.Unbounded_String;

      Initial_Configure : Boolean := True;

      Surface : Surface_With_Window (Wayland_Window'Access);

      XDG_Surface  : Xdg_Surface_With_Window (Wayland_Window'Access);
      XDG_Toplevel : Xdg_Toplevel_With_Window (Wayland_Window'Access);

      Decoration   : Toplevel_Decoration_With_Window (Wayland_Window'Access);

      Frame_Handler : Frame_Handler_With_Window (Wayland_Window'Access);

      --  Wayland.EGL
      EGL_Window  : Standard.Wayland.EGL.Window;

      --  EGL
      EGL_Surface : EGL.Objects.Surfaces.Surface (EGL.Objects.Displays.Wayland);
      EGL_Context : EGL.Objects.Contexts.Context (EGL.Objects.Displays.Wayland);
      EGL_Config  : EGL.Objects.Configs.Config;
      EGL_sRGB    : Boolean;

      Should_Close : Boolean := False with Atomic;

      Idle_Inhibitor : II.Idle_Inhibitor_V1;

      Pointer_State  : AWT.Inputs.Pointer_State;
      Keyboard_State : AWT.Inputs.Keyboard_State;

      Locked_Pointer        : Locked_Pointer_With_Window (Wayland_Window'Access);
      Locked_Position       : AWT.Inputs.Coordinate;
      Unlocked_Pointer_Mode : AWT.Inputs.Pointer_Mode;
      Raw_Pointer_Motion    : Boolean := False;

      Cursor_Surface : WP.Client.Surface;
      Cursor_Hotspot : Cursor_Hotspot_Coordinate := (others => 0);
      Cursor         : AWT.Inputs.Cursors.Pointer_Cursor := AWT.Inputs.Cursors.Default;
      Cursor_Images  : Positive := 1;
   end record;

   overriding
   procedure Create_Window
     (Object                        : aliased in out Wayland_Window;
      ID, Title                     : String;
      Width, Height                 : Positive;
      Visible, Resizable, Decorated : Boolean := True;
      Transparent                   : Boolean := False);

   overriding procedure Finalize (Object : in out Wayland_Window);

   overriding
   procedure Set_Application_ID (Object : in out Wayland_Window; ID : String);

   overriding
   procedure Set_Application_Title (Object : in out Wayland_Window; Title : String);

   overriding
   procedure Set_Size (Object : in out Wayland_Window; Width, Height : Positive);

   overriding
   procedure Set_Size_Limits
     (Object : in out Wayland_Window;
      Min_Width, Min_Height, Max_Width, Max_Height : Natural);

   overriding
   procedure Set_Size_Mode (Object : in out Wayland_Window; Mode : AWT.Windows.Size_Mode);

   overriding
   procedure Set_Size_Mode
     (Object  : in out Wayland_Window;
      Mode    : AWT.Windows.Size_Mode;
      Monitor : AWT.Monitors.Monitor'Class);

   overriding
   procedure Set_Framebuffer_Scale (Object : in out Wayland_Window; Scale : Positive);

   overriding
   procedure Set_Raw_Pointer_Motion (Object : in out Wayland_Window; Enable : Boolean);

   overriding
   procedure Set_Margin
     (Object : in out Wayland_Window;
      Margin : Natural);

   overriding
   procedure Set_Visible (Object : in out Wayland_Window; Visible : Boolean);

   overriding
   procedure Set_Pointer_Cursor
     (Object : in out Wayland_Window;
      Cursor : AWT.Inputs.Cursors.Pointer_Cursor);

   overriding
   procedure Set_Pointer_Mode
     (Object : in out Wayland_Window;
      Mode   : AWT.Inputs.Pointer_Mode);

   overriding
   function Raw_Pointer_Motion (Object : Wayland_Window) return Boolean;

   overriding
   function State (Object : Wayland_Window) return AWT.Windows.Window_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Windows.Framebuffer_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Inputs.Pointer_State;

   overriding
   function State (Object : Wayland_Window) return AWT.Inputs.Keyboard_State;

   overriding
   procedure Close (Object : in out Wayland_Window);

   overriding
   function Should_Close (Object : Wayland_Window) return Boolean;

   overriding
   procedure Swap_Buffers (Object : in out Wayland_Window);

   overriding
   procedure Set_Vertical_Sync (Object : in out Wayland_Window; Enable : Boolean);

   overriding
   function On_Close (Object : Wayland_Window) return Boolean;

   function On_Change_Cursor
     (Object : in out Wayland_Window;
      Name   : AWT.Inputs.Cursors.Pointer_Cursor;
      Cursor : WC.Cursor'Class) return WC.Cursor_Image'Class;

end AWT.Wayland.Windows;

wayland: Add a comment to AWT.Wayland.Windows showing a graph of objects

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


-----------------------------------------------------------------------
--  ado-drivers-tests -- Unit tests for database drivers
--  Copyright (C) 2014, 2015, 2016 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.Tests;
package ADO.Drivers.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test the Initialize operation.
   procedure Test_Initialize (T : in out Test);

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

   --  Test the Set_Connection procedure.
   procedure Test_Set_Connection (T : in out Test);

   --  Test the Set_Connection procedure with several error cases.
   procedure Test_Set_Connection_Error (T : in out Test);

   --  Test the Set_Server operation.
   procedure Test_Set_Connection_Server (T : in out Test);

   --  Test the Set_Port operation.
   procedure Test_Set_Connection_Port (T : in out Test);

   --  Test the connection operations on an empty connection.
   procedure Test_Empty_Connection (T : in out Test);

end ADO.Drivers.Tests;

-----------------------------------------------------------------------
--  ado-drivers-tests -- Unit tests for database drivers
--  Copyright (C) 2014, 2015, 2016 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.Tests;
package ADO.Drivers.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test the Initialize operation.
   procedure Test_Initialize (T : in out Test);

   --  Test the Get_Config operation.
   procedure Test_Get_Config (T : in out Test);

   --  Test the Get_Driver operation.
   procedure Test_Get_Driver (T : in out Test);

   --  Test loading some invalid database driver.
   procedure Test_Load_Invalid_Driver (T : in out Test);

   --  Test the Get_Driver_Index operation.
   procedure Test_Get_Driver_Index (T : in out Test);

   --  Test the Set_Connection procedure.
   procedure Test_Set_Connection (T : in out Test);

   --  Test the Set_Connection procedure with several error cases.
   procedure Test_Set_Connection_Error (T : in out Test);

   --  Test the Set_Server operation.
   procedure Test_Set_Connection_Server (T : in out Test);

   --  Test the Set_Port operation.
   procedure Test_Set_Connection_Port (T : in out Test);

   --  Test the Set_Database operation.
   procedure Test_Set_Connection_Database (T : in out Test);

   --  Test the connection operations on an empty connection.
   procedure Test_Empty_Connection (T : in out Test);

end ADO.Drivers.Tests;

Declare Test_Set_Connection_Database procedure