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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;
with Util.Strings;

with ADO.Sessions;

with EL.Variables.Default;
with EL.Contexts.Default;

with AWA.Modules.Get;
with AWA.Applications;
with AWA.Storages.Modules;
with AWA.Services.Contexts;
with AWA.Modules.Beans;
with AWA.Images.Beans;
package body AWA.Images.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Module");

   package Register is new AWA.Modules.Beans (Module        => Image_Module,
                                              Module_Access => Image_Module_Access);

   --  ------------------------------
   --  Job worker procedure to identify an image and generate its thumnbnail.
   --  ------------------------------
   procedure Thumbnail_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Module : constant Image_Module_Access := Get_Image_Module;
   begin
      Module.Do_Thumbnail_Job (Job);
   end Thumbnail_Worker;

   --  ------------------------------
   --  Initialize the image module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Image_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the image module");

      --  Setup the resource bundles.
      App.Register ("imageMsg", "images");

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Images.Beans.Image_List_Bean",
                         Handler => AWA.Images.Beans.Create_Image_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Images.Beans.Image_Bean",
                         Handler => AWA.Images.Beans.Create_Image_Bean'Access);

      App.Add_Servlet ("image", Plugin.Image_Servlet'Unchecked_Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.Add_Listener (AWA.Storages.Modules.NAME, Plugin'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having
   --  read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Image_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);

      use type AWA.Jobs.Modules.Job_Module_Access;
   begin
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      if Plugin.Job_Module = null then
         Log.Error ("Cannot find the AWA Job module for the image thumbnail generation");
      else
         Plugin.Job_Module.Register (Definition => Thumbnail_Job_Definition.Factory);
      end if;
      Plugin.Thumbnail_Command := Plugin.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Configure;

   --  ------------------------------
   --  Create a thumbnail job for the image.
   --  ------------------------------
   procedure Make_Thumbnail_Job (Plugin : in Image_Module;
                                 Image  : in AWA.Images.Models.Image_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("image_id", Image);
      J.Schedule (Thumbnail_Job_Definition.Factory.all);
   end Make_Thumbnail_Job;

   --  ------------------------------
   --  Returns true if the storage file has an image mime type.
   --  ------------------------------
   function Is_Image (File : in AWA.Storages.Models.Storage_Ref'Class) return Boolean is
      Mime : constant String := File.Get_Mime_Type;
      Pos  : constant Natural := Util.Strings.Index (Mime, '/');
   begin
      if Pos = 0 then
         return False;
      else
         return Mime (Mime'First .. Pos - 1) = "image";
      end if;
   end Is_Image;

   --  ------------------------------
   --  Create an image instance.
   --  ------------------------------
   procedure Create_Image (Plugin  : in Image_Module;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if File.Get_Original.Is_Null then
         declare
            Ctx : constant ASC.Service_Context_Access := ASC.Current;
            DB  : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
            Img : AWA.Images.Models.Image_Ref;
         begin
            Img.Set_Width (0);
            Img.Set_Height (0);
            Img.Set_Thumb_Height (0);
            Img.Set_Thumb_Width (0);
            Img.Set_Storage (File);
            Img.Set_Folder (File.Get_Folder);
            Img.Set_Owner (File.Get_Owner);
            Img.Save (DB);
            Plugin.Make_Thumbnail_Job (Img);
         end;
      end if;
   end Create_Image;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify
   --  the creation of the item.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if Is_Image (Item) then
         Image_Module'Class (Instance).Create_Image (Item);
      end if;
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify
   --  the update of the item.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if Is_Image (Item) then
         Image_Module'Class (Instance).Create_Image (Item);
      else
         Image_Module'Class (Instance).Delete_Image (Item);
      end if;
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify
   --  the deletion of the item.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      Image_Module'Class (Instance).Delete_Image (Item);
   end On_Delete;

   --  ------------------------------
   --  Thumbnail job to identify the image dimension and produce a thumbnail.
   --  ------------------------------
   procedure Do_Thumbnail_Job (Plugin : in Image_Module;
                               Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Image_Id : constant ADO.Identifier := Job.Get_Parameter ("image_id");
   begin
      Image_Module'Class (Plugin).Build_Thumbnail (Image_Id);
   end Do_Thumbnail_Job;

   --  ------------------------------
   --  Get the image module instance associated with the current application.
   --  ------------------------------
   function Get_Image_Module return Image_Module_Access is
      function Get is new AWA.Modules.Get (Image_Module, Image_Module_Access, NAME);
   begin
      return Get;
   end Get_Image_Module;

   procedure Create_Thumbnail (Service : in Image_Module;
                               Source  : in String;
                               Into    : in String;
                               Width   : in out Natural;
                               Height  : in out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Variables.Bind ("width", Util.Beans.Objects.To_Object (Width));
      Variables.Bind ("height", Util.Beans.Objects.To_Object (Height));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information
               --  about the original image.  Extract the picture width and
               --  height.
               --  image.png PNG 120x282 120x282+0+0 8-bit \
               --         DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Module;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Thumb       : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File (AWA.Storages.TMP);
      Local_File  : AWA.Storages.Storage_File (AWA.Storages.CACHE);
      Thumbnail   : AWA.Storages.Models.Storage_Ref;
      Width       : Natural := 64;
      Height      : Natural := 64;
   begin
      Img.Load (DB, Id);
      declare
         Image_File : constant AWA.Storages.Models.Storage_Ref'Class := Img.Get_Storage;
      begin
         Storage_Service.Get_Local_File (From => Image_File.Get_Id, Into => Local_File);
         Storage_Service.Create_Local_File (Target_File);

         Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                   AWA.Storages.Get_Path (Target_File), Width, Height);
         Thumbnail.Set_Mime_Type ("image/jpeg");
         Thumbnail.Set_Original (Image_File);
         Thumbnail.Set_Workspace (Image_File.Get_Workspace);
         Thumbnail.Set_Folder (Image_File.Get_Folder);
         Thumbnail.Set_Owner (Image_File.Get_Owner);
         Thumbnail.Set_Name (String '(Image_File.Get_Name));
         Storage_Service.Save (Thumbnail, AWA.Storages.Get_Path (Target_File),
                               AWA.Storages.Models.DATABASE);
         Thumb.Set_Width (64);
         Thumb.Set_Height (64);
         Thumb.Set_Owner (Image_File.Get_Owner);
         Thumb.Set_Folder (Image_File.Get_Folder);
         Thumb.Set_Storage (Thumbnail);
         Img.Set_Width (Width);
         Img.Set_Height (Height);
         Img.Set_Thumb_Width (64);
         Img.Set_Thumb_Height (64);
         Img.Set_Thumbnail (Thumbnail);
         Ctx.Start;
         Img.Save (DB);
         Thumb.Save (DB);
         Ctx.Commit;
      end;
   end Build_Thumbnail;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Module;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

   --  ------------------------------
   --  Scale the image dimension.
   --  ------------------------------
   procedure Scale (Width     : in Natural;
                    Height    : in Natural;
                    To_Width  : in out Natural;
                    To_Height : in out Natural) is
   begin
      if To_Width = Natural'Last or To_Height = Natural'Last
        or (To_Width = 0 and To_Height = 0)
      then
         To_Width  := Width;
         To_Height := Height;
      elsif To_Width = 0 then
         To_Width := (Width * To_Height) / Height;
      elsif To_Height = 0 then
         To_Height := (Height * To_Width) / Width;
      end if;
   end Scale;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one
   --  of the following formats:
   --    original          -> Width, Height := Natural'Last
   --    default           -> Width, Height := 0
   --    <width>x          -> Width := <width>, Height := 0
   --    x<height>         -> Width := 0, Height := <height>
   --    <width>x<height>  -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in String;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" then
         Width  := 800;
         Height := 0;
      else
         Pos := Util.Strings.Index (Dimension, 'x');
         if Pos > Dimension'First then
            begin
               Width := Natural'Value (Dimension (Dimension'First .. Pos - 1));

            exception
               when Constraint_Error =>
                  Width := 0;
            end;
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            begin
               Height := Natural'Value (Dimension (Pos + 1 .. Dimension'Last));

            exception
               when Constraint_Error =>
                  Height := 0;
            end;
         else
            Height := 0;
         end if;
      end if;
   end Get_Sizes;

end AWA.Images.Modules;

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

with Util.Processes;
with Util.Beans.Objects;
with Util.Log.Loggers;
with Util.Streams.Pipes;
with Util.Streams.Texts;
with Util.Strings;

with ADO.Sessions;

with EL.Variables.Default;
with EL.Contexts.Default;

with AWA.Modules.Get;
with AWA.Applications;
with AWA.Storages.Modules;
with AWA.Services.Contexts;
with AWA.Modules.Beans;
with AWA.Images.Beans;
package body AWA.Images.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Images.Module");

   package Register is new AWA.Modules.Beans (Module        => Image_Module,
                                              Module_Access => Image_Module_Access);

   --  ------------------------------
   --  Job worker procedure to identify an image and generate its thumnbnail.
   --  ------------------------------
   procedure Thumbnail_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Module : constant Image_Module_Access := Get_Image_Module;
   begin
      Module.Do_Thumbnail_Job (Job);
   end Thumbnail_Worker;

   --  ------------------------------
   --  Initialize the image module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Image_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the image module");

      --  Setup the resource bundles.
      App.Register ("imageMsg", "images");

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Images.Beans.Image_List_Bean",
                         Handler => AWA.Images.Beans.Create_Image_List_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Images.Beans.Image_Bean",
                         Handler => AWA.Images.Beans.Create_Image_Bean'Access);

      App.Add_Servlet ("image", Plugin.Image_Servlet'Unchecked_Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.Add_Listener (AWA.Storages.Modules.NAME, Plugin'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having
   --  read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Image_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);

      use type AWA.Jobs.Modules.Job_Module_Access;
   begin
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      if Plugin.Job_Module = null then
         Log.Error ("Cannot find the AWA Job module for the image thumbnail generation");
      else
         Plugin.Job_Module.Register (Definition => Thumbnail_Job_Definition.Factory);
      end if;
      Plugin.Thumbnail_Command := Plugin.Get_Config (PARAM_THUMBNAIL_COMMAND);
   end Configure;

   --  ------------------------------
   --  Create a thumbnail job for the image.
   --  ------------------------------
   procedure Make_Thumbnail_Job (Plugin : in Image_Module;
                                 Image  : in AWA.Images.Models.Image_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("image_id", Image);
      J.Schedule (Thumbnail_Job_Definition.Factory.all);
   end Make_Thumbnail_Job;

   --  ------------------------------
   --  Returns true if the storage file has an image mime type.
   --  ------------------------------
   function Is_Image (File : in AWA.Storages.Models.Storage_Ref'Class) return Boolean is
      Mime : constant String := File.Get_Mime_Type;
      Pos  : constant Natural := Util.Strings.Index (Mime, '/');
   begin
      if Pos = 0 then
         return False;
      else
         return Mime (Mime'First .. Pos - 1) = "image";
      end if;
   end Is_Image;

   --  ------------------------------
   --  Create an image instance.
   --  ------------------------------
   procedure Create_Image (Plugin  : in Image_Module;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if File.Get_Original.Is_Null then
         declare
            Ctx : constant ASC.Service_Context_Access := ASC.Current;
            DB  : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
            Img : AWA.Images.Models.Image_Ref;
         begin
            Img.Set_Width (0);
            Img.Set_Height (0);
            Img.Set_Thumb_Height (0);
            Img.Set_Thumb_Width (0);
            Img.Set_Storage (File);
            Img.Set_Folder (File.Get_Folder);
            Img.Set_Owner (File.Get_Owner);
            Img.Save (DB);
            Plugin.Make_Thumbnail_Job (Img);
         end;
      end if;
   end Create_Image;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify
   --  the creation of the item.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if Is_Image (Item) then
         Image_Module'Class (Instance).Create_Image (Item);
      end if;
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify
   --  the update of the item.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      if Is_Image (Item) then
         Image_Module'Class (Instance).Create_Image (Item);
      else
         Image_Module'Class (Instance).Delete_Image (Item);
      end if;
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify
   --  the deletion of the item.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Image_Module;
                        Item     : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      Image_Module'Class (Instance).Delete_Image (Item);
   end On_Delete;

   --  ------------------------------
   --  Thumbnail job to identify the image dimension and produce a thumbnail.
   --  ------------------------------
   procedure Do_Thumbnail_Job (Plugin : in Image_Module;
                               Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Image_Id : constant ADO.Identifier := Job.Get_Parameter ("image_id");
   begin
      Image_Module'Class (Plugin).Build_Thumbnail (Image_Id);
   end Do_Thumbnail_Job;

   --  ------------------------------
   --  Get the image module instance associated with the current application.
   --  ------------------------------
   function Get_Image_Module return Image_Module_Access is
      function Get is new AWA.Modules.Get (Image_Module, Image_Module_Access, NAME);
   begin
      return Get;
   end Get_Image_Module;

   procedure Create_Thumbnail (Service : in Image_Module;
                               Source  : in String;
                               Into    : in String;
                               Width   : in out Natural;
                               Height  : in out Natural) is
      Ctx       : EL.Contexts.Default.Default_Context;
      Variables : aliased EL.Variables.Default.Default_Variable_Mapper;

      Proc    : Util.Processes.Process;
      Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
   begin
      Variables.Bind ("src", Util.Beans.Objects.To_Object (Source));
      Variables.Bind ("dst", Util.Beans.Objects.To_Object (Into));
      Variables.Bind ("width", Util.Beans.Objects.To_Object (Width));
      Variables.Bind ("height", Util.Beans.Objects.To_Object (Height));
      Ctx.Set_Variable_Mapper (Variables'Unchecked_Access);
      declare
         Cmd     : constant Util.Beans.Objects.Object := Service.Thumbnail_Command.Get_Value (Ctx);
         Command : constant String := Util.Beans.Objects.To_String (Cmd);
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Width  := 0;
         Height := 0;
         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               use Ada.Strings;

               Line : Ada.Strings.Unbounded.Unbounded_String;
               Pos  : Natural;
               Sep  : Natural;
               Last : Natural;
            begin
               Input.Read_Line (Into  => Line, Strip => False);
               exit when Ada.Strings.Unbounded.Length (Line) = 0;
               Log.Info ("Received: {0}", Line);

               --  The '-verbose' option of ImageMagick reports information
               --  about the original image.  Extract the picture width and
               --  height.
               --  image.png PNG 120x282 120x282+0+0 8-bit \
               --         DirectClass 34.4KB 0.000u 0:00.018
               Pos := Ada.Strings.Unbounded.Index (Line, " ");
               if Pos > 0 and then Width = 0 then
                  Pos := Ada.Strings.Unbounded.Index (Line, " ", Pos + 1);
                  if Pos > 0 then
                     Sep := Ada.Strings.Unbounded.Index (Line, "x", Pos + 1);
                     Last := Ada.Strings.Unbounded.Index (Line, "=", Pos + 1);
                     if Sep > 0 and then Sep < Last then
                        Log.Info ("Dimension {0} - {1}..{2}",
                                  Ada.Strings.Unbounded.Slice (Line, Pos, Last),
                                  Natural'Image (Pos), Natural'Image (Last));
                        Width := Natural'Value (Unbounded.Slice (Line, Pos + 1, Sep - 1));
                        Height := Natural'Value (Unbounded.Slice (Line, Sep + 1, Last - 1));
                     end if;
                  end if;
               end if;
            end;
         end loop;
         Pipe.Close;

         Util.Processes.Wait (Proc);
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Create_Thumbnail;

   --  Build a thumbnail for the image identified by the Id.
   procedure Build_Thumbnail (Service : in Image_Module;
                              Id      : in ADO.Identifier) is
      Storage_Service : constant AWA.Storages.Services.Storage_Service_Access
        := AWA.Storages.Modules.Get_Storage_Manager;
      Ctx         : constant ASC.Service_Context_Access := ASC.Current;
      DB          : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Img         : AWA.Images.Models.Image_Ref;
      Thumb       : AWA.Images.Models.Image_Ref;
      Target_File : AWA.Storages.Storage_File (AWA.Storages.TMP);
      Local_File  : AWA.Storages.Storage_File (AWA.Storages.CACHE);
      Thumbnail   : AWA.Storages.Models.Storage_Ref;
      Width       : Natural := 64;
      Height      : Natural := 64;
   begin
      Img.Load (DB, Id);
      declare
         Image_File : constant AWA.Storages.Models.Storage_Ref'Class := Img.Get_Storage;
      begin
         Storage_Service.Get_Local_File (From => Image_File.Get_Id, Into => Local_File);
         Storage_Service.Create_Local_File (Target_File);

         Service.Create_Thumbnail (AWA.Storages.Get_Path (Local_File),
                                   AWA.Storages.Get_Path (Target_File), Width, Height);
         Thumbnail.Set_Mime_Type ("image/jpeg");
         Thumbnail.Set_Original (Image_File);
         Thumbnail.Set_Workspace (Image_File.Get_Workspace);
         Thumbnail.Set_Folder (Image_File.Get_Folder);
         Thumbnail.Set_Owner (Image_File.Get_Owner);
         Thumbnail.Set_Name (String '(Image_File.Get_Name));
         Storage_Service.Save (Thumbnail, AWA.Storages.Get_Path (Target_File),
                               AWA.Storages.Models.DATABASE);
         Thumb.Set_Width (64);
         Thumb.Set_Height (64);
         Thumb.Set_Owner (Image_File.Get_Owner);
         Thumb.Set_Folder (Image_File.Get_Folder);
         Thumb.Set_Storage (Thumbnail);
         Img.Set_Width (Width);
         Img.Set_Height (Height);
         Img.Set_Thumb_Width (64);
         Img.Set_Thumb_Height (64);
         Img.Set_Thumbnail (Thumbnail);
         Ctx.Start;
         Img.Save (DB);
         Thumb.Save (DB);
         Ctx.Commit;
      end;
   end Build_Thumbnail;

   --  Deletes the storage instance.
   procedure Delete_Image (Service : in Image_Module;
                           File    : in AWA.Storages.Models.Storage_Ref'Class) is
   begin
      null;
   end Delete_Image;

   --  ------------------------------
   --  Scale the image dimension.
   --  ------------------------------
   procedure Scale (Width     : in Natural;
                    Height    : in Natural;
                    To_Width  : in out Natural;
                    To_Height : in out Natural) is
   begin
      if To_Width = Natural'Last or else To_Height = Natural'Last
        or else (To_Width = 0 and then To_Height = 0)
      then
         To_Width  := Width;
         To_Height := Height;
      elsif To_Width = 0 then
         To_Width := (Width * To_Height) / Height;
      elsif To_Height = 0 then
         To_Height := (Height * To_Width) / Width;
      end if;
   end Scale;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one
   --  of the following formats:
   --    original          -> Width, Height := Natural'Last
   --    default           -> Width, Height := 0
   --    <width>x          -> Width := <width>, Height := 0
   --    x<height>         -> Width := 0, Height := <height>
   --    <width>x<height>  -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in String;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" then
         Width  := 800;
         Height := 0;
      else
         Pos := Util.Strings.Index (Dimension, 'x');
         if Pos > Dimension'First then
            begin
               Width := Natural'Value (Dimension (Dimension'First .. Pos - 1));

            exception
               when Constraint_Error =>
                  Width := 0;
            end;
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            begin
               Height := Natural'Value (Dimension (Pos + 1 .. Dimension'Last));

            exception
               when Constraint_Error =>
                  Height := 0;
            end;
         else
            Height := 0;
         end if;
      end if;
   end Get_Sizes;

end AWA.Images.Modules;

Fix style warnings: add missing overriding and update and then/or else conditions


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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
with MAT.Readers.Streams.Sockets;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
   Server  : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Server.Start (Options.Address);
   MAT.Commands.Interactive (Target);
   Server.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Server.Stop;
end Matp;

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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
with MAT.Readers.Streams.Sockets;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
   Server  : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Target.Start;
   MAT.Commands.Interactive (Target);
   Server.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Server.Stop;
end Matp;

Update to call the target Start procedure


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

package body SSD1306 is

   procedure Write_Command (This : SSD1306_Screen;
                            Cmd  : UInt8);

   procedure Write_Data (This : SSD1306_Screen;
                         Data : UInt8_Array);

   -------------------
   -- Write_Command --
   -------------------

   procedure Write_Command (This : SSD1306_Screen;
                            Cmd  : UInt8)
   is
      Status : I2C_Status;
   begin
      This.Port.Master_Transmit (Addr    => SSD1306_I2C_Addr,
                                 Data    => (1 => 0, 2 => (Cmd)),
                                 Status  => Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
   end Write_Command;

   ----------------
   -- Write_Data --
   ----------------

   procedure Write_Data (This : SSD1306_Screen;
                         Data : UInt8_Array)
   is
      Status : I2C_Status;
   begin
      This.Port.Master_Transmit (Addr    => SSD1306_I2C_Addr,
                                 Data    => Data,
                                 Status  => Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
   end Write_Data;

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

   procedure Initialize (This         : in out SSD1306_Screen;
                         External_VCC : Boolean)
   is
   begin

      if This.Width * This.Height /= (This.Buffer_Size_In_Byte * 8) then
         raise Program_Error with "Invalid screen parameters";
      end if;

      This.RST.Clear;
      This.Time.Delay_Milliseconds (100);
      This.RST.Set;
      This.Time.Delay_Milliseconds (100);

      Write_Command (This, DISPLAY_OFF);

      Write_Command (This, SET_DISPLAY_CLOCK_DIV);
      Write_Command (This, 16#80#);

      Write_Command (This, SET_MULTIPLEX);
      Write_Command (This, UInt8 (This.Height - 1));

      Write_Command (This, SET_DISPLAY_OFFSET);
      Write_Command (This, 16#00#);

      Write_Command (This, SET_START_LINE or 0);

      Write_Command (This, CHARGE_PUMP);
      Write_Command (This, (if External_VCC then 16#10# else 16#14#));

      Write_Command (This, MEMORY_MODE);
      Write_Command (This, 16#00#);

      Write_Command (This, SEGREMAP or 1);

      Write_Command (This, COM_SCAN_DEC);

      Write_Command (This, SET_COMPINS);
      Write_Command (This, 16#02#);
      Write_Command (This, SET_CONTRAST);
      Write_Command (This, 16#AF#);

      Write_Command (This, SET_PRECHARGE);
      Write_Command (This, (if External_VCC then 16#22# else 16#F1#));

      Write_Command (This, SET_VCOM_DETECT);
      Write_Command (This, 16#40#);

      Write_Command (This, DISPLAY_ALL_ON_RESUME);
      Write_Command (This, NORMAL_DISPLAY);
      Write_Command (This, DEACTIVATE_SCROLL);

      This.Device_Initialized := True;
   end Initialize;

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

   overriding
   function Initialized (This : SSD1306_Screen) return Boolean is
     (This.Device_Initialized);

   -------------
   -- Turn_On --
   -------------

   procedure Turn_On (This : SSD1306_Screen) is
   begin
      Write_Command (This, DISPLAY_ON);
   end Turn_On;

   --------------
   -- Turn_Off --
   --------------

   procedure Turn_Off (This : SSD1306_Screen) is
   begin
      Write_Command (This, DISPLAY_OFF);
   end Turn_Off;

   --------------------------
   -- Display_Inversion_On --
   --------------------------

   procedure Display_Inversion_On (This : SSD1306_Screen) is
   begin
      Write_Command (This, INVERT_DISPLAY);
   end Display_Inversion_On;

   ---------------------------
   -- Display_Inversion_Off --
   ---------------------------

   procedure Display_Inversion_Off (This : SSD1306_Screen) is
   begin
      Write_Command (This, NORMAL_DISPLAY);
   end Display_Inversion_Off;

   ----------------------
   -- Write_Raw_Pixels --
   ----------------------

   procedure Write_Raw_Pixels (This  : SSD1306_Screen;
                               Data : HAL.UInt8_Array)
   is
   begin
      Write_Command (This, COLUMN_ADDR);
      Write_Command (This, 0);                   --  from
      Write_Command (This, UInt8 (This.Width - 1));  --  to

      Write_Command (This, PAGE_ADDR);
      Write_Command (This, 0);                           --  from
      Write_Command (This, UInt8 (This.Height / 8) - 1); --  to

      Write_Data (This, (1 => 16#40#) & Data);
   end Write_Raw_Pixels;

   --------------------
   -- Get_Max_Layers --
   --------------------

   overriding
   function Max_Layers
     (This : SSD1306_Screen) return Positive is (1);

   ------------------
   -- Is_Supported --
   ------------------

   overriding
   function Supported
     (This : SSD1306_Screen;
      Mode : FB_Color_Mode) return Boolean is
     (Mode = HAL.Bitmap.RGB_565);

   ---------------------
   -- Set_Orientation --
   ---------------------

   overriding
   procedure Set_Orientation
     (This        : in out SSD1306_Screen;
      Orientation : Display_Orientation)
   is
   begin
      null;
   end Set_Orientation;

   --------------
   -- Set_Mode --
   --------------

   overriding
   procedure Set_Mode
     (This : in out SSD1306_Screen;
      Mode : Wait_Mode)
   is
   begin
      null;
   end Set_Mode;

   ---------------
   -- Get_Width --
   ---------------

   overriding
   function Width
     (This : SSD1306_Screen) return Positive is (This.Width);

   ----------------
   -- Get_Height --
   ----------------

   overriding
   function Height
     (This : SSD1306_Screen) return Positive is (This.Height);

   ----------------
   -- Is_Swapped --
   ----------------

   overriding
   function Swapped
     (This : SSD1306_Screen) return Boolean is (False);

   --------------------
   -- Set_Background --
   --------------------

   overriding
   procedure Set_Background
     (This : SSD1306_Screen; R, G, B : UInt8)
   is
   begin
      --  Does it make sense when there's no alpha channel...
      raise Program_Error;
   end Set_Background;

   ----------------------
   -- Initialize_Layer --
   ----------------------

   overriding
   procedure Initialize_Layer
     (This   : in out SSD1306_Screen;
      Layer  : Positive;
      Mode   : FB_Color_Mode;
      X      : Natural := 0;
      Y      : Natural := 0;
      Width  : Positive := Positive'Last;
      Height : Positive := Positive'Last)
   is
      pragma Unreferenced (X, Y, Width, Height);
   begin
      if Layer /= 1 or else Mode /= M_1 then
         raise Program_Error;
      end if;
      This.Memory_Layer.Actual_Width := This.Width;
      This.Memory_Layer.Actual_Height := This.Height;
      This.Memory_Layer.Addr := This.Memory_Layer.Data'Address;
      This.Memory_Layer.Actual_Color_Mode := Mode;
      This.Layer_Initialized := True;
   end Initialize_Layer;

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

   overriding
   function Initialized
     (This  : SSD1306_Screen;
      Layer : Positive) return Boolean
   is
   begin
      return Layer = 1 and then This.Layer_Initialized;
   end Initialized;

   ------------------
   -- Update_Layer --
   ------------------

   overriding
   procedure Update_Layer
     (This      : in out SSD1306_Screen;
      Layer     : Positive;
      Copy_Back : Boolean := False)
   is
      pragma Unreferenced (Copy_Back);
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;

      This.Write_Raw_Pixels (This.Memory_Layer.Data);
   end Update_Layer;

   -------------------
   -- Update_Layers --
   -------------------

   overriding
   procedure Update_Layers
     (This : in out SSD1306_Screen)
   is
   begin
      This.Update_Layer (1);
   end  Update_Layers;

   --------------------
   -- Get_Color_Mode --
   --------------------

   overriding
   function Color_Mode
     (This  : SSD1306_Screen;
      Layer : Positive) return FB_Color_Mode
   is
      pragma Unreferenced (This);
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;
      return M_1;
   end Color_Mode;

   -----------------------
   -- Get_Hidden_Buffer --
   -----------------------

   overriding
   function Hidden_Buffer
     (This  : in out SSD1306_Screen;
      Layer : Positive) return not null HAL.Bitmap.Any_Bitmap_Buffer
   is
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;
      return This.Memory_Layer'Unchecked_Access;
   end Hidden_Buffer;

   --------------------
   -- Get_Pixel_Size --
   --------------------

   overriding
   function Pixel_Size
     (This  : SSD1306_Screen;
      Layer : Positive) return Positive is (1);

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point)
   is
      X     : constant Natural := Buffer.Width - 1 - Pt.X;
      Y     : constant Natural := Buffer.Height - 1 - Pt.Y;
      Index : constant Natural :=  X + (Y / 8) * Buffer.Actual_Width;
      Byte  : UInt8 renames Buffer.Data (Buffer.Data'First + Index);
   begin

      if Buffer.Native_Source = 0 then
         Byte := Byte and not (Shift_Left (1, Y mod 8));
      else
         Byte := Byte or Shift_Left (1, Y mod 8);
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point;
      Color   : Bitmap_Color)
   is
   begin
      Buffer.Set_Pixel (Pt, (if Color = Black then 0 else 1));
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point;
      Raw     : UInt32)
   is
   begin
      Buffer.Native_Source := Raw;
      Buffer.Set_Pixel (Pt);
   end Set_Pixel;

   -----------
   -- Pixel --
   -----------

   overriding
   function Pixel
     (Buffer : SSD1306_Bitmap_Buffer;
      Pt     : Point)
      return Bitmap_Color
   is
   begin
      return (if Buffer.Pixel (Pt) = 0 then Black else White);
   end Pixel;

   -----------
   -- Pixel --
   -----------

   overriding
   function Pixel
     (Buffer : SSD1306_Bitmap_Buffer;
      Pt     : Point)
      return UInt32
   is
      X     : constant Natural := Buffer.Width - 1 - Pt.X;
      Y     : constant Natural := Buffer.Height - 1 - Pt.Y;
      Index : constant Natural :=  X + (Y / 8) * Buffer.Actual_Width;
      Byte  : UInt8 renames Buffer.Data (Buffer.Data'First + Index);
   begin

      if (Byte and (Shift_Left (1, Y mod 8))) /= 0 then
         return 1;
      else
         return 0;
      end if;
   end Pixel;

   ----------
   -- Fill --
   ----------

   overriding
   procedure Fill
     (Buffer : in out SSD1306_Bitmap_Buffer)
   is
      Val : constant UInt8 := (if Buffer.Native_Source /= 0 then 16#FF# else 0);
   begin
      Buffer.Data := (others => Val);
   end Fill;

end SSD1306;

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

package body SSD1306 is

   procedure Write_Command (This : SSD1306_Screen;
                            Cmd  : UInt8);

   procedure Write_Data (This : SSD1306_Screen;
                         Data : UInt8_Array);

   -------------------
   -- Write_Command --
   -------------------

   procedure Write_Command (This : SSD1306_Screen;
                            Cmd  : UInt8)
   is
      Status : I2C_Status;
   begin
      This.Port.Master_Transmit (Addr    => SSD1306_I2C_Addr,
                                 Data    => (1 => 0, 2 => (Cmd)),
                                 Status  => Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
   end Write_Command;

   ----------------
   -- Write_Data --
   ----------------

   procedure Write_Data (This : SSD1306_Screen;
                         Data : UInt8_Array)
   is
      Status : I2C_Status;
   begin
      This.Port.Master_Transmit (Addr    => SSD1306_I2C_Addr,
                                 Data    => Data,
                                 Status  => Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
   end Write_Data;

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

   procedure Initialize (This         : in out SSD1306_Screen;
                         External_VCC : Boolean)
   is
   begin

      if This.Width * This.Height /= (This.Buffer_Size_In_Byte * 8) then
         raise Program_Error with "Invalid screen parameters";
      end if;

      This.RST.Clear;
      This.Time.Delay_Milliseconds (100);
      This.RST.Set;
      This.Time.Delay_Milliseconds (100);

      Write_Command (This, DISPLAY_OFF);

      Write_Command (This, SET_DISPLAY_CLOCK_DIV);
      Write_Command (This, 16#80#);

      Write_Command (This, SET_MULTIPLEX);
      Write_Command (This, UInt8 (This.Height - 1));

      Write_Command (This, SET_DISPLAY_OFFSET);
      Write_Command (This, 16#00#);

      Write_Command (This, SET_START_LINE or 0);

      Write_Command (This, CHARGE_PUMP);
      Write_Command (This, (if External_VCC then 16#10# else 16#14#));

      Write_Command (This, MEMORY_MODE);
      Write_Command (This, 16#00#);

      Write_Command (This, SEGREMAP or 1);

      Write_Command (This, COM_SCAN_DEC);

      Write_Command (This, SET_COMPINS);
      if This.Height > 32 then
         Write_Command (This, 16#12#);
      else
         Write_Command (This, 16#02#);
      end if;

      Write_Command (This, SET_CONTRAST);
      Write_Command (This, 16#AF#);

      Write_Command (This, SET_PRECHARGE);
      Write_Command (This, (if External_VCC then 16#22# else 16#F1#));

      Write_Command (This, SET_VCOM_DETECT);
      Write_Command (This, 16#40#);

      Write_Command (This, DISPLAY_ALL_ON_RESUME);
      Write_Command (This, NORMAL_DISPLAY);
      Write_Command (This, DEACTIVATE_SCROLL);

      This.Device_Initialized := True;
   end Initialize;

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

   overriding
   function Initialized (This : SSD1306_Screen) return Boolean is
     (This.Device_Initialized);

   -------------
   -- Turn_On --
   -------------

   procedure Turn_On (This : SSD1306_Screen) is
   begin
      Write_Command (This, DISPLAY_ON);
   end Turn_On;

   --------------
   -- Turn_Off --
   --------------

   procedure Turn_Off (This : SSD1306_Screen) is
   begin
      Write_Command (This, DISPLAY_OFF);
   end Turn_Off;

   --------------------------
   -- Display_Inversion_On --
   --------------------------

   procedure Display_Inversion_On (This : SSD1306_Screen) is
   begin
      Write_Command (This, INVERT_DISPLAY);
   end Display_Inversion_On;

   ---------------------------
   -- Display_Inversion_Off --
   ---------------------------

   procedure Display_Inversion_Off (This : SSD1306_Screen) is
   begin
      Write_Command (This, NORMAL_DISPLAY);
   end Display_Inversion_Off;

   ----------------------
   -- Write_Raw_Pixels --
   ----------------------

   procedure Write_Raw_Pixels (This  : SSD1306_Screen;
                               Data : HAL.UInt8_Array)
   is
   begin
      Write_Command (This, COLUMN_ADDR);
      Write_Command (This, 0);                   --  from
      Write_Command (This, UInt8 (This.Width - 1));  --  to

      Write_Command (This, PAGE_ADDR);
      Write_Command (This, 0);                           --  from
      Write_Command (This, UInt8 (This.Height / 8) - 1); --  to

      Write_Data (This, (1 => 16#40#) & Data);
   end Write_Raw_Pixels;

   --------------------
   -- Get_Max_Layers --
   --------------------

   overriding
   function Max_Layers
     (This : SSD1306_Screen) return Positive is (1);

   ------------------
   -- Is_Supported --
   ------------------

   overriding
   function Supported
     (This : SSD1306_Screen;
      Mode : FB_Color_Mode) return Boolean is
     (Mode = HAL.Bitmap.RGB_565);

   ---------------------
   -- Set_Orientation --
   ---------------------

   overriding
   procedure Set_Orientation
     (This        : in out SSD1306_Screen;
      Orientation : Display_Orientation)
   is
   begin
      null;
   end Set_Orientation;

   --------------
   -- Set_Mode --
   --------------

   overriding
   procedure Set_Mode
     (This : in out SSD1306_Screen;
      Mode : Wait_Mode)
   is
   begin
      null;
   end Set_Mode;

   ---------------
   -- Get_Width --
   ---------------

   overriding
   function Width
     (This : SSD1306_Screen) return Positive is (This.Width);

   ----------------
   -- Get_Height --
   ----------------

   overriding
   function Height
     (This : SSD1306_Screen) return Positive is (This.Height);

   ----------------
   -- Is_Swapped --
   ----------------

   overriding
   function Swapped
     (This : SSD1306_Screen) return Boolean is (False);

   --------------------
   -- Set_Background --
   --------------------

   overriding
   procedure Set_Background
     (This : SSD1306_Screen; R, G, B : UInt8)
   is
   begin
      --  Does it make sense when there's no alpha channel...
      raise Program_Error;
   end Set_Background;

   ----------------------
   -- Initialize_Layer --
   ----------------------

   overriding
   procedure Initialize_Layer
     (This   : in out SSD1306_Screen;
      Layer  : Positive;
      Mode   : FB_Color_Mode;
      X      : Natural := 0;
      Y      : Natural := 0;
      Width  : Positive := Positive'Last;
      Height : Positive := Positive'Last)
   is
      pragma Unreferenced (X, Y, Width, Height);
   begin
      if Layer /= 1 or else Mode /= M_1 then
         raise Program_Error;
      end if;
      This.Memory_Layer.Actual_Width  := This.Width;
      This.Memory_Layer.Actual_Height := This.Height;
      This.Memory_Layer.Addr := This.Memory_Layer.Data'Address;
      This.Memory_Layer.Actual_Color_Mode := Mode;
      This.Layer_Initialized := True;
   end Initialize_Layer;

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

   overriding
   function Initialized
     (This  : SSD1306_Screen;
      Layer : Positive) return Boolean
   is
   begin
      return Layer = 1 and then This.Layer_Initialized;
   end Initialized;

   ------------------
   -- Update_Layer --
   ------------------

   overriding
   procedure Update_Layer
     (This      : in out SSD1306_Screen;
      Layer     : Positive;
      Copy_Back : Boolean := False)
   is
      pragma Unreferenced (Copy_Back);
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;

      This.Write_Raw_Pixels (This.Memory_Layer.Data);
   end Update_Layer;

   -------------------
   -- Update_Layers --
   -------------------

   overriding
   procedure Update_Layers
     (This : in out SSD1306_Screen)
   is
   begin
      This.Update_Layer (1);
   end  Update_Layers;

   --------------------
   -- Get_Color_Mode --
   --------------------

   overriding
   function Color_Mode
     (This  : SSD1306_Screen;
      Layer : Positive) return FB_Color_Mode
   is
      pragma Unreferenced (This);
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;
      return M_1;
   end Color_Mode;

   -----------------------
   -- Get_Hidden_Buffer --
   -----------------------

   overriding
   function Hidden_Buffer
     (This  : in out SSD1306_Screen;
      Layer : Positive) return not null HAL.Bitmap.Any_Bitmap_Buffer
   is
   begin
      if Layer /= 1 then
         raise Program_Error;
      end if;
      return This.Memory_Layer'Unchecked_Access;
   end Hidden_Buffer;

   --------------------
   -- Get_Pixel_Size --
   --------------------

   overriding
   function Pixel_Size
     (This  : SSD1306_Screen;
      Layer : Positive) return Positive is (1);

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point)
   is
      X     : constant Natural := Buffer.Width - 1 - Pt.X;
      Y     : constant Natural := Buffer.Height - 1 - Pt.Y;
      Index : constant Natural := X + (Y / 8) * Buffer.Actual_Width;
      Byte  : UInt8 renames Buffer.Data (Buffer.Data'First + Index);
   begin

      if Buffer.Native_Source = 0 then
         Byte := Byte and not (Shift_Left (1, Y mod 8));
      else
         Byte := Byte or Shift_Left (1, Y mod 8);
      end if;
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point;
      Color   : Bitmap_Color)
   is
   begin
      Buffer.Set_Pixel (Pt, (if Color = Black then 0 else 1));
   end Set_Pixel;

   ---------------
   -- Set_Pixel --
   ---------------

   overriding
   procedure Set_Pixel
     (Buffer  : in out SSD1306_Bitmap_Buffer;
      Pt      : Point;
      Raw     : UInt32)
   is
   begin
      Buffer.Native_Source := Raw;
      Buffer.Set_Pixel (Pt);
   end Set_Pixel;

   -----------
   -- Pixel --
   -----------

   overriding
   function Pixel
     (Buffer : SSD1306_Bitmap_Buffer;
      Pt     : Point)
      return Bitmap_Color
   is
   begin
      return (if Buffer.Pixel (Pt) = 0 then Black else White);
   end Pixel;

   -----------
   -- Pixel --
   -----------

   overriding
   function Pixel
     (Buffer : SSD1306_Bitmap_Buffer;
      Pt     : Point)
      return UInt32
   is
      X     : constant Natural := Buffer.Width - 1 - Pt.X;
      Y     : constant Natural := Buffer.Height - 1 - Pt.Y;
      Index : constant Natural :=  X + (Y / 8) * Buffer.Actual_Width;
      Byte  : UInt8 renames Buffer.Data (Buffer.Data'First + Index);
   begin

      if (Byte and (Shift_Left (1, Y mod 8))) /= 0 then
         return 1;
      else
         return 0;
      end if;
   end Pixel;

   ----------
   -- Fill --
   ----------

   overriding
   procedure Fill
     (Buffer : in out SSD1306_Bitmap_Buffer)
   is
      Val : constant UInt8 := (if Buffer.Native_Source /= 0 then 16#FF# else 0);
   begin
      Buffer.Data := (others => Val);
   end Fill;

end SSD1306;

Fix initialization for 128x64 displays

SSD1306: Fix initialization for 128x64 displays


-----------------------------------------------------------------------
--  ASF tests - ASF Tests Framework
--  Copyright (C) 2011, 2012, 2015 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.Properties;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Server;
with ASF.Applications.Main;
with Util.Tests;

with EL.Contexts.Default;
with EL.Variables;

with GNAT.Source_Info;

--  The <b>ASF.Tests</b> package provides a set of utility procedures to write a unit test
--  on top of ASF.
package ASF.Tests is

   --  Initialize the asf test framework mockup.  If the application is not specified,
   --  a default ASF application is created.
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class);

   --  Get the server
   function Get_Server return access ASF.Server.Container;

   --  Get the test application.
   function Get_Application return ASF.Applications.Main.Application_Access;

   --  Simulate a GET request on the given URI with the request parameters.
   --  Get the result in the response object.
   procedure Do_Get (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response;
                     URI      : in String;
                     Save     : in String := "");

   --  Simulate a POST request on the given URI with the request parameters.
   --  Get the result in the response object.
   procedure Do_Post (Request  : in out ASF.Requests.Mockup.Request;
                      Response : in out ASF.Responses.Mockup.Response;
                      URI      : in String;
                      Save     : in String := "");

   --  Simulate a raw request.  The URI and method must have been set on the Request object.
   procedure Do_Req (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response);

   --  Check that the response body contains the string
   procedure Assert_Contains (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line);

   --  Check that the response body matches the regular expression
   procedure Assert_Matches (T       : in Util.Tests.Test'Class;
                             Pattern : in String;
                             Reply   : in out ASF.Responses.Mockup.Response;
                             Message : in String := "Test failed";
                             Status  : in Natural := ASF.Responses.SC_OK;
                             Source  : String := GNAT.Source_Info.File;
                             Line    : Natural := GNAT.Source_Info.Line);

   --  Check that the response body is a redirect to the given URI.
   procedure Assert_Redirect (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line);

   type EL_Test is new Util.Tests.Test with record
      --  The ELContext, Variables, Resolver, Form area controlled object.
      --  Due to AUnit implementation, we cannot store a controlled object in the Test object.
      --  This is due to the 'for Obj'Address use Ret;' clause used by AUnit to allocate
      --  a test object.
      --  The application object is allocated dyanmically by Set_Up.
      ELContext      : EL.Contexts.Default.Default_Context_Access;
      Variables      : EL.Variables.Variable_Mapper_Access;
      Root_Resolver  : EL.Contexts.Default.Default_ELResolver_Access;
   end record;

   --  Cleanup the test instance.
   overriding
   procedure Tear_Down (T : in out EL_Test);

   --  Setup the test instance.
   overriding
   procedure Set_Up (T : in out EL_Test);

end ASF.Tests;

-----------------------------------------------------------------------
--  ASF tests - ASF Tests Framework
--  Copyright (C) 2011, 2012, 2015 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.Properties;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Server;
with ASF.Applications.Main;
with Util.Tests;

with EL.Contexts.Default;
with EL.Variables;

with GNAT.Source_Info;

--  The <b>ASF.Tests</b> package provides a set of utility procedures to write a unit test
--  on top of ASF.
package ASF.Tests is

   --  Initialize the asf test framework mockup.  If the application is not specified,
   --  a default ASF application is created.
   procedure Initialize (Props       : in Util.Properties.Manager;
                         Application : in ASF.Applications.Main.Application_Access := null;
                         Factory     : in out ASF.Applications.Main.Application_Factory'Class);

   --  Get the server
   function Get_Server return access ASF.Server.Container;

   --  Get the test application.
   function Get_Application return ASF.Applications.Main.Application_Access;

   --  Simulate a GET request on the given URI with the request parameters.
   --  Get the result in the response object.
   procedure Do_Get (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response;
                     URI      : in String;
                     Save     : in String := "");

   --  Simulate a POST request on the given URI with the request parameters.
   --  Get the result in the response object.
   procedure Do_Post (Request  : in out ASF.Requests.Mockup.Request;
                      Response : in out ASF.Responses.Mockup.Response;
                      URI      : in String;
                      Save     : in String := "");

   --  Simulate a raw request.  The URI and method must have been set on the Request object.
   procedure Do_Req (Request  : in out ASF.Requests.Mockup.Request;
                     Response : in out ASF.Responses.Mockup.Response);

   --  Check that the response body contains the string
   procedure Assert_Contains (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line);

   --  Check that the response body matches the regular expression
   procedure Assert_Matches (T       : in Util.Tests.Test'Class;
                             Pattern : in String;
                             Reply   : in out ASF.Responses.Mockup.Response;
                             Message : in String := "Test failed";
                             Status  : in Natural := ASF.Responses.SC_OK;
                             Source  : String := GNAT.Source_Info.File;
                             Line    : Natural := GNAT.Source_Info.Line);

   --  Check that the response body is a redirect to the given URI.
   procedure Assert_Redirect (T       : in Util.Tests.Test'Class;
                              Value   : in String;
                              Reply   : in out ASF.Responses.Mockup.Response;
                              Message : in String := "Test failed";
                              Source  : String := GNAT.Source_Info.File;
                              Line    : Natural := GNAT.Source_Info.Line);

   --  Check that the response contains the given header.
   procedure Assert_Header (T       : in Util.Tests.Test'Class;
                            Header  : in String;
                            Value   : in String;
                            Reply   : in out ASF.Responses.Mockup.Response;
                            Message : in String := "Test failed";
                            Status  : in Natural := ASF.Responses.SC_OK;
                            Source  : String := GNAT.Source_Info.File;
                            Line    : Natural := GNAT.Source_Info.Line);

   type EL_Test is new Util.Tests.Test with record
      --  The ELContext, Variables, Resolver, Form area controlled object.
      --  Due to AUnit implementation, we cannot store a controlled object in the Test object.
      --  This is due to the 'for Obj'Address use Ret;' clause used by AUnit to allocate
      --  a test object.
      --  The application object is allocated dyanmically by Set_Up.
      ELContext      : EL.Contexts.Default.Default_Context_Access;
      Variables      : EL.Variables.Variable_Mapper_Access;
      Root_Resolver  : EL.Contexts.Default.Default_ELResolver_Access;
   end record;

   --  Cleanup the test instance.
   overriding
   procedure Tear_Down (T : in out EL_Test);

   --  Setup the test instance.
   overriding
   procedure Set_Up (T : in out EL_Test);

end ASF.Tests;

Declare the Assert_Header procedure to check that the response contains the expected header


with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Text_IO;

with AWT.Clipboard;
with AWT.Drag_And_Drop;
with AWT.Inputs;
with AWT.Monitors;
with AWT.Windows;

with Orka.Contexts.AWT;
with Orka.Debug;

with Package_Test;

procedure Example is
   use Ada.Text_IO;

   Index : Positive := 1;
   Monitor_Events, Last_Monitor_Events : Positive := 1;
   Border_Size : constant := 50;
   Should_Be_Visible : Boolean := True;
   Visible_Index : Positive := 1;

   Visible_Index_Count : constant := 100;

   procedure Print_Monitor (Monitor : AWT.Monitors.Monitor_Ptr) is
      State : constant AWT.Monitors.Monitor_State := Monitor.State;

      use AWT.Monitors;
   begin
      Put_Line ("monitor:" & Monitor.ID'Image);
      Put_Line ("      name: " & (+State.Name));
      Put_Line ("      x, y: " & State.X'Image & ", " & State.Y'Image);
      Put_Line ("      w x h: " & State.Width'Image & " × " & State.Height'Image);
      Put_Line ("      refresh: " & State.Refresh'Image);
   end Print_Monitor;

   type Test_Listener is new AWT.Monitors.Monitor_Event_Listener with null record;

   overriding procedure On_Connect    (Object : Test_Listener; Monitor : AWT.Monitors.Monitor_Ptr);
   overriding procedure On_Disconnect (Object : Test_Listener; Monitor : AWT.Monitors.Monitor_Ptr);

   overriding
   procedure On_Connect
     (Object  : Test_Listener;
      Monitor : AWT.Monitors.Monitor_Ptr) is
   begin
      Put_Line ("connected:");
      Print_Monitor (Monitor);
      Monitor_Events := Monitor_Events + 1;
   end On_Connect;

   overriding
   procedure On_Disconnect
     (Object  : Test_Listener;
      Monitor : AWT.Monitors.Monitor_Ptr) is
   begin
      Put_Line ("disconnected:");
      Print_Monitor (Monitor);
      Monitor_Events := Monitor_Events + 1;
   end On_Disconnect;

   Monitor_Listener : Test_Listener;
begin
   Put_Line ("Initializing...");
   AWT.Initialize;
   Put_Line ("Initialized");

   for Monitor of AWT.Monitors.Monitors loop
      Print_Monitor (Monitor);
   end loop;

   declare
      Next_Cursor : AWT.Inputs.Cursors.Pointer_Cursor :=
        AWT.Inputs.Cursors.Pointer_Cursor'First;

      Last_Pointer  : AWT.Inputs.Pointer_State;
      Last_Keyboard : AWT.Inputs.Keyboard_State;

      use Ada.Real_Time;

      Interval : constant Duration := To_Duration (Microseconds (16_667));
      Flip_Size : Boolean := False;

      Context : constant Orka.Contexts.Surface_Context'Class :=
        Orka.Contexts.AWT.Create_Context
          (Version => (4, 2),
           Flags   => (Debug | Robust => True, others => False));

      Window : Package_Test.Test_Window := Package_Test.Create_Window
        (Context, 600, 400, Visible => True, Transparent => True, Title => "init test");
      AWT_Window : AWT.Windows.Window'Class renames AWT.Windows.Window'Class (Window);

      task Render_Task is
         entry Start_Rendering;
      end Render_Task;

      task body Render_Task is
      begin
         Put_Line ("Render task waiting to get started...");
         accept Start_Rendering;
         Put_Line ("Render task started");
         Context.Make_Current (Window);
         Put_Line ("Window made current on context");

         Orka.Debug.Set_Log_Messages (Enable => True);
         Put_Line ("Context version: " & Orka.Contexts.Image (Context.Version));

         Window.Post_Initialize;

         Put_Line ("Rendering...");
         loop
            exit when Window.Should_Close;
            delay until Clock + Microseconds (15000);
            Window.Render;
         end loop;
         Put_Line ("Rendering done");
         Context.Make_Not_Current;
         Put_Line ("Render task, context made not current");
      exception
         when E : others =>
            Put_Line (Ada.Exceptions.Exception_Information (E));
            Context.Make_Not_Current;
            raise;
      end Render_Task;
   begin
      Last_Pointer  := AWT_Window.State;
      Last_Keyboard := AWT_Window.State;

      Context.Make_Not_Current;
      Put_Line ("Context made not current in main task");
      Render_Task.Start_Rendering;
      Put_Line ("Render task started by main task");

      Window.Set_Margin (Border_Size);
      Put_Line ("Starting event loop...");
      while not Window.Should_Close and then AWT.Process_Events (Interval) loop
--         AWT_Window.Set_Title (Index'Image & " " & Next_Cursor'Image);
         Index := Index + 1;

         select
            Package_Test.Dnd_Signal.Wait;

            declare
               Result : constant String := AWT.Drag_And_Drop.Get;
            begin
               Put_Line ("value: '" & Result & "'");
               AWT.Drag_And_Drop.Finish (AWT.Inputs.Copy);
            end;
         else
            null;
         end select;

         if not Should_Be_Visible  then
            Put_Line (Positive'Image (Visible_Index + Visible_Index_Count) & Index'Image);
            if Index > Visible_Index + Visible_Index_Count then
               Should_Be_Visible := True;
               AWT_Window.Set_Title ("visible! " & Visible_Index'Image);
               AWT_Window.Set_Visible (True);
               Put_Line ("window visible");
            end if;
         end if;

--         if Index = 100 then
--            AWT_Window.Set_Visible (True);
--         end if;

         if Monitor_Events /= Last_Monitor_Events then
            Put_Line ("Monitor count: " & Natural'Image (AWT.Monitors.Monitors'Length));
            Last_Monitor_Events := Monitor_Events;
         end if;

         declare
            Pointer : constant AWT.Inputs.Pointer_State := AWT_Window.State;

            use all type AWT.Inputs.Button_State;
            use all type AWT.Inputs.Dimension;
            use all type AWT.Inputs.Pointer_Button;
            use all type AWT.Inputs.Pointer_Mode;
            use type AWT.Inputs.Cursors.Pointer_Cursor;
         begin
--            if False then
--               Put_Line ("focused:   " & Pointer.Focused'Image);
--               Put_Line ("scrolling: " & Pointer.Scrolling'Image);
--               Put_Line ("buttons:");
--               Put_Line ("    left: " & Pointer.Buttons (Left)'Image);
--               Put_Line ("  middle: " & Pointer.Buttons (Middle)'Image);
--               Put_Line ("   right: " & Pointer.Buttons (Right)'Image);
--               Put_Line ("mode: " & Pointer.Mode'Image);
--               Put_Line ("position: " & Pointer.Position (X)'Image & Pointer.Position (Y)'Image);
--               Put_Line ("relative: " & Pointer.Relative (X)'Image & Pointer.Relative (Y)'Image);
--               Put_Line ("scroll: " & Pointer.Scroll (X)'Image & Pointer.Scroll (Y)'Image);
--            end if;

--            if Last_Pointer.Focused and not Pointer.Focused then
--               Window.Set_Pointer_Cursor (AWT.Inputs.Cursors.Pointer_Cursor'Last);
--            end if;

            if Pointer.Buttons (Left) = Pressed
              and Last_Pointer.Buttons (Left) = Released
            then
               Next_Cursor :=
                 (if Next_Cursor = AWT.Inputs.Cursors.Pointer_Cursor'Last then
                    AWT.Inputs.Cursors.Pointer_Cursor'First
                  else
                    AWT.Inputs.Cursors.Pointer_Cursor'Succ (Next_Cursor));
               AWT_Window.Set_Pointer_Cursor (Next_Cursor);
            end if;

            if Pointer.Buttons (Right) = Pressed
              and Last_Pointer.Buttons (Right) = Released
              and Pointer.Mode /= Locked
            then
               Put_Line ("locking!");
               AWT_Window.Set_Pointer_Mode (Locked);
            elsif Pointer.Buttons (Right) = Released
              and Last_Pointer.Buttons (Right) = Pressed
              and Pointer.Mode = Locked
            then
               Put_Line ("unlocking!");
               AWT_Window.Set_Pointer_Mode (Visible);
            end if;

            Last_Pointer := Pointer;
         end;

         declare
            Keyboard : constant AWT.Inputs.Keyboard_State := AWT_Window.State;

            use type AWT.Inputs.Keyboard_Modifiers;
            use all type AWT.Inputs.Button_State;
            use all type AWT.Inputs.Keyboard_Button;
         begin
            if Keyboard.Modifiers.Ctrl
              and Last_Keyboard.Buttons (Key_C) = Pressed
              and Keyboard.Buttons (Key_C) = Released
            then
               declare
                  Value : constant String := "foobar" & Index'Image;
               begin
                  AWT.Clipboard.Set (Value);
                  Put_Line ("Set clipboard: '" & Value & "'");
               end;
            end if;

            if Keyboard.Modifiers.Ctrl
              and Last_Keyboard.Buttons (Key_V) = Pressed
              and Keyboard.Buttons (Key_V) = Released
            then
               Put_Line ("Get clipboard: '" & AWT.Clipboard.Get & "'");
            end if;

--            Put_Line ("focused: " & Keyboard.Focused'Image);
--            Put_Line ("repeat:");
--            Put_Line ("  rate:  " & Keyboard.Repeat_Rate'Image);
--            Put_Line ("  delay: " & Keyboard.Repeat_Delay'Image);
--            if False and Keyboard.Modifiers /= Last_Keyboard.Modifiers then
--               Put_Line ("Shift:       " & Keyboard.Modifiers.Shift'Image);
--               Put_Line ("Caps_Lock:   " & Keyboard.Modifiers.Caps_Lock'Image);
--               Put_Line ("Ctrl:        " & Keyboard.Modifiers.Ctrl'Image);
--               Put_Line ("Alt:         " & Keyboard.Modifiers.Alt'Image);
--               Put_Line ("Num_Lock:    " & Keyboard.Modifiers.Num_Lock'Image);
--               Put_Line ("Logo:        " & Keyboard.Modifiers.Logo'Image);
--            end if;

            declare
               use all type AWT.Windows.Size_Mode;
            begin
               if Keyboard.Modifiers.Ctrl
                 and Last_Keyboard.Buttons (Key_F) = Pressed
                 and Keyboard.Buttons (Key_F) = Released
               then
                  if AWT_Window.State.Mode = Fullscreen then
                     AWT_Window.Set_Size_Mode (Default);
                  else
                     AWT_Window.Set_Size_Mode (Fullscreen);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl
                 and Last_Keyboard.Buttons (Key_M) = Pressed
                 and Keyboard.Buttons (Key_M) = Released
               then
                  if AWT_Window.State.Mode = Maximized then
                     AWT_Window.Set_Size_Mode (Default);
                  else
                     AWT_Window.Set_Size_Mode (Maximized);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl
                 and Last_Keyboard.Buttons (Key_S) = Pressed
                 and Keyboard.Buttons (Key_S) = Released
               then
                  Flip_Size := not Flip_Size;
                  if Flip_Size then
                     AWT_Window.Set_Size (1280, 720);
                  else
                     AWT_Window.Set_Size (600, 400);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl
                 and Last_Keyboard.Buttons (Key_H) = Pressed
                 and Keyboard.Buttons (Key_H) = Released
               then
                  Should_Be_Visible := False;
                  Visible_Index := Index;
                  AWT_Window.Set_Visible (False);
                  Put_Line ("window hidden");
               end if;
            end;

            Last_Keyboard := Keyboard;
         end;
      end loop;
      Put_Line ("Exited event loop");
   exception
      when E : others =>
         Put_Line ("main: " & Ada.Exceptions.Exception_Information (E));
         raise;
   end;
end Example;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Text_IO;

with AWT.Clipboard;
with AWT.Drag_And_Drop;
with AWT.Inputs;
with AWT.Monitors;
with AWT.Windows;

with Orka.Contexts.AWT;
with Orka.Debug;

with Package_Test;

procedure Example is
   use Ada.Text_IO;

   Index : Positive := 1;
   Monitor_Events, Last_Monitor_Events : Positive := 1;
   Border_Size : constant := 50;
   Should_Be_Visible : Boolean := True;
   Visible_Index : Positive := 1;

   Visible_Index_Count : constant := 100;

   procedure Print_Monitor (Monitor : AWT.Monitors.Monitor_Ptr) is
      State : constant AWT.Monitors.Monitor_State := Monitor.State;

      use AWT.Monitors;
   begin
      Put_Line ("monitor:" & Monitor.ID'Image);
      Put_Line ("      name: " & (+State.Name));
      Put_Line ("      x, y: " & State.X'Image & ", " & State.Y'Image);
      Put_Line ("      w x h: " & State.Width'Image & " × " & State.Height'Image);
      Put_Line ("      refresh: " & State.Refresh'Image);
   end Print_Monitor;

   type Test_Listener is new AWT.Monitors.Monitor_Event_Listener with null record;

   overriding procedure On_Connect    (Object : Test_Listener; Monitor : AWT.Monitors.Monitor_Ptr);
   overriding procedure On_Disconnect (Object : Test_Listener; Monitor : AWT.Monitors.Monitor_Ptr);

   overriding
   procedure On_Connect
     (Object  : Test_Listener;
      Monitor : AWT.Monitors.Monitor_Ptr) is
   begin
      Put_Line ("connected:");
      Print_Monitor (Monitor);
      Monitor_Events := Monitor_Events + 1;
   end On_Connect;

   overriding
   procedure On_Disconnect
     (Object  : Test_Listener;
      Monitor : AWT.Monitors.Monitor_Ptr) is
   begin
      Put_Line ("disconnected:");
      Print_Monitor (Monitor);
      Monitor_Events := Monitor_Events + 1;
   end On_Disconnect;

   Monitor_Listener : Test_Listener;
begin
   Put_Line ("Initializing...");
   AWT.Initialize;
   Put_Line ("Initialized");

   for Monitor of AWT.Monitors.Monitors loop
      Print_Monitor (Monitor);
   end loop;

   declare
      Next_Cursor : AWT.Inputs.Cursors.Pointer_Cursor :=
        AWT.Inputs.Cursors.Pointer_Cursor'First;

      Last_Pointer  : AWT.Inputs.Pointer_State;

      use Ada.Real_Time;

      Interval : constant Duration := To_Duration (Microseconds (16_667));
      Flip_Size : Boolean := False;

      Context : constant Orka.Contexts.Surface_Context'Class :=
        Orka.Contexts.AWT.Create_Context
          (Version => (4, 2),
           Flags   => (Debug | Robust => True, others => False));

      Window : Package_Test.Test_Window := Package_Test.Create_Window
        (Context, 600, 400, Visible => True, Transparent => True, Title => "init test");
      AWT_Window : AWT.Windows.Window'Class renames AWT.Windows.Window'Class (Window);

      task Render_Task is
         entry Start_Rendering;
      end Render_Task;

      task body Render_Task is
      begin
         Put_Line ("Render task waiting to get started...");
         accept Start_Rendering;
         Put_Line ("Render task started");
         Context.Make_Current (Window);
         Put_Line ("Window made current on context");

         Orka.Debug.Set_Log_Messages (Enable => True);
         Put_Line ("Context version: " & Orka.Contexts.Image (Context.Version));

         Window.Post_Initialize;

         Put_Line ("Rendering...");
         loop
            exit when Window.Should_Close;
            delay until Clock + Microseconds (15000);
            Window.Render;
         end loop;
         Put_Line ("Rendering done");
         Context.Make_Not_Current;
         Put_Line ("Render task, context made not current");
      exception
         when E : others =>
            Put_Line (Ada.Exceptions.Exception_Information (E));
            Context.Make_Not_Current;
            raise;
      end Render_Task;
   begin
      Last_Pointer  := AWT_Window.State;

      Context.Make_Not_Current;
      Put_Line ("Context made not current in main task");
      Render_Task.Start_Rendering;
      Put_Line ("Render task started by main task");

      Window.Set_Margin (Border_Size);
      Put_Line ("Starting event loop...");
      while not Window.Should_Close loop
         AWT.Process_Events (Interval);
--         AWT_Window.Set_Title (Index'Image & " " & Next_Cursor'Image);
         Index := Index + 1;

         select
            Package_Test.Dnd_Signal.Wait;

            declare
               Result : constant String := AWT.Drag_And_Drop.Get;
            begin
               Put_Line ("value: '" & Result & "'");
               AWT.Drag_And_Drop.Finish (AWT.Inputs.Copy);
            end;
         else
            null;
         end select;

         if not Should_Be_Visible  then
            Put_Line (Positive'Image (Visible_Index + Visible_Index_Count) & Index'Image);
            if Index > Visible_Index + Visible_Index_Count then
               Should_Be_Visible := True;
               AWT_Window.Set_Title ("visible! " & Visible_Index'Image);
               AWT_Window.Set_Visible (True);
               Put_Line ("window visible");
            end if;
         end if;

--         if Index = 100 then
--            AWT_Window.Set_Visible (True);
--         end if;

         if Monitor_Events /= Last_Monitor_Events then
            Put_Line ("Monitor count: " & Natural'Image (AWT.Monitors.Monitors'Length));
            Last_Monitor_Events := Monitor_Events;
         end if;

         declare
            Pointer : constant AWT.Inputs.Pointer_State := AWT_Window.State;

            use all type AWT.Inputs.Button_State;
            use all type AWT.Inputs.Dimension;
            use all type AWT.Inputs.Pointer_Button;
            use all type AWT.Inputs.Pointer_Mode;
            use type AWT.Inputs.Cursors.Pointer_Cursor;
         begin
--            if False then
--               Put_Line ("focused:   " & Pointer.Focused'Image);
--               Put_Line ("scrolling: " & Pointer.Scrolling'Image);
--               Put_Line ("buttons:");
--               Put_Line ("    left: " & Pointer.Buttons (Left)'Image);
--               Put_Line ("  middle: " & Pointer.Buttons (Middle)'Image);
--               Put_Line ("   right: " & Pointer.Buttons (Right)'Image);
--               Put_Line ("mode: " & Pointer.Mode'Image);
--               Put_Line ("position: " & Pointer.Position (X)'Image & Pointer.Position (Y)'Image);
--               Put_Line ("relative: " & Pointer.Relative (X)'Image & Pointer.Relative (Y)'Image);
--               Put_Line ("scroll: " & Pointer.Scroll (X)'Image & Pointer.Scroll (Y)'Image);
--            end if;

--            if Last_Pointer.Focused and not Pointer.Focused then
--               Window.Set_Pointer_Cursor (AWT.Inputs.Cursors.Pointer_Cursor'Last);
--            end if;

            if Pointer.Buttons (Left) = Pressed
              and Last_Pointer.Buttons (Left) = Released
            then
               Next_Cursor :=
                 (if Next_Cursor = AWT.Inputs.Cursors.Pointer_Cursor'Last then
                    AWT.Inputs.Cursors.Pointer_Cursor'First
                  else
                    AWT.Inputs.Cursors.Pointer_Cursor'Succ (Next_Cursor));
               AWT_Window.Set_Pointer_Cursor (Next_Cursor);
            end if;

            if Pointer.Buttons (Right) = Pressed
              and Last_Pointer.Buttons (Right) = Released
              and Pointer.Mode /= Locked
            then
               Put_Line ("locking!");
               AWT_Window.Set_Pointer_Mode (Locked);
            elsif Pointer.Buttons (Right) = Released
              and Last_Pointer.Buttons (Right) = Pressed
              and Pointer.Mode = Locked
            then
               Put_Line ("unlocking!");
               AWT_Window.Set_Pointer_Mode (Visible);
            end if;

            Last_Pointer := Pointer;
         end;

         declare
            Keyboard : constant AWT.Inputs.Keyboard_State := AWT_Window.State;

            use type AWT.Inputs.Keyboard_Modifiers;
            use all type AWT.Inputs.Button_State;
            use all type AWT.Inputs.Keyboard_Button;
         begin
            if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_C) then
               declare
                  Value : constant String := "foobar" & Index'Image;
               begin
                  AWT.Clipboard.Set (Value);
                  Put_Line ("Set clipboard: '" & Value & "'");
               end;
            end if;

            if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_V) then
               Put_Line ("Get clipboard: '" & AWT.Clipboard.Get & "'");
            end if;

--            Put_Line ("focused: " & Keyboard.Focused'Image);
--            Put_Line ("repeat:");
--            Put_Line ("  rate:  " & Keyboard.Repeat_Rate'Image);
--            Put_Line ("  delay: " & Keyboard.Repeat_Delay'Image);
--            if False and Keyboard.Modifiers /= Last_Keyboard.Modifiers then
--               Put_Line ("Shift:       " & Keyboard.Modifiers.Shift'Image);
--               Put_Line ("Caps_Lock:   " & Keyboard.Modifiers.Caps_Lock'Image);
--               Put_Line ("Ctrl:        " & Keyboard.Modifiers.Ctrl'Image);
--               Put_Line ("Alt:         " & Keyboard.Modifiers.Alt'Image);
--               Put_Line ("Num_Lock:    " & Keyboard.Modifiers.Num_Lock'Image);
--               Put_Line ("Logo:        " & Keyboard.Modifiers.Logo'Image);
--            end if;

            declare
               use all type AWT.Windows.Size_Mode;
            begin
               if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_F) then
                  if AWT_Window.State.Mode = Fullscreen then
                     AWT_Window.Set_Size_Mode (Default);
                  else
                     AWT_Window.Set_Size_Mode (Fullscreen);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_M) then
                  if AWT_Window.State.Mode = Maximized then
                     AWT_Window.Set_Size_Mode (Default);
                  else
                     AWT_Window.Set_Size_Mode (Maximized);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_S) then
                  Flip_Size := not Flip_Size;
                  if Flip_Size then
                     AWT_Window.Set_Size (1280, 720);
                  else
                     AWT_Window.Set_Size (600, 400);
                  end if;
               end if;

               if Keyboard.Modifiers.Ctrl and Keyboard.Pressed (Key_H) then
                  Should_Be_Visible := False;
                  Visible_Index := Index;
                  AWT_Window.Set_Visible (False);
                  Put_Line ("window hidden");
               end if;
            end;
         end;
      end loop;
      Put_Line ("Exited event loop");
   exception
      when E : others =>
         Put_Line ("main: " & Ada.Exceptions.Exception_Information (E));
         raise;
   end;
end Example;

awt: Fix and clean up example code after changing AWT.Process_Events

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


-----------------------------------------------------------------------
--  mat-readers-files -- Reader for files
--  Copyright (C) 2014, 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.Streams.Stream_IO;

with Util.Log.Loggers;
package body MAT.Readers.Streams.Files is

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

   BUFFER_SIZE  : constant Natural := 100 * 1024;

   --  ------------------------------
   --  Open the file.
   --  ------------------------------
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String) is
      Stream : constant access Util.Streams.Input_Stream'Class := Reader.File'Access;
   begin
      Log.Info ("Reading data stream {0}", Path);

      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Stream);
      Reader.File.Open (Mode => Ada.Streams.Stream_IO.In_File,
                        Name => Path);
   end Open;

end MAT.Readers.Streams.Files;

-----------------------------------------------------------------------
--  mat-readers-files -- Reader for files
--  Copyright (C) 2014, 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.Streams.Stream_IO;

with Util.Log.Loggers;
package body MAT.Readers.Streams.Files is

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

   BUFFER_SIZE  : constant Natural := 100 * 1024;

   --  ------------------------------
   --  Open the file.
   --  ------------------------------
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String) is
      Stream : constant access Util.Streams.Input_Stream'Class := Reader.File'Unchecked_Access;
   begin
      Log.Info ("Reading data stream {0}", Path);

      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Stream);
      Reader.File.Open (Mode => Ada.Streams.Stream_IO.In_File,
                        Name => Path);
   end Open;

end MAT.Readers.Streams.Files;

Fix compilation warning

Fix compilation warning