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

with Util.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

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

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result : Util.Beans.Basic.Readonly_Bean_Access;
      Ctx    : EL.Contexts.Default.Default_Context;
      Scope  : Scope_Type;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "en_GB",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, fr;q=0.7, fr-fr;q=0.8");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "fr_FR",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

-----------------------------------------------------------------------
--  asf-applications-main-tests - Unit tests for Applications
--  Copyright (C) 2011, 2012, 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 Util.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

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

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path    : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result  : Util.Beans.Basic.Readonly_Bean_Access;
      Context : aliased ASF.Contexts.Faces.Faces_Context;
      Ctx     : aliased EL.Contexts.Default.Default_Context;
      Scope   : Scope_Type;
   begin
      Context.Set_ELContext (Ctx'Unchecked_Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "en_GB",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, fr;q=0.7, fr-fr;q=0.8");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "fr_FR",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

Fix the Test_Bundle_Configuration that requires a faces context to be executed


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

with Util.Test_Caller;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Create_Image",
                       Test_Create_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

end AWA.Images.Modules.Tests;

-----------------------------------------------------------------------
--  awa-storages-modules-tests -- Unit tests for storage service
--  Copyright (C) 2012, 2013, 2016, 2019, 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 Util.Test_Caller;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Modules.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Create_Image",
                       Test_Create_Image'Access);
      Caller.Add_Test (Suite, "Test AWA.Images.Get_Sizes",
                       Test_Get_Sizes'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String
        := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural := 64;
      Height    : Natural := 64;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Module;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

   --  ------------------------------
   --  Test the Get_Sizes operation.
   --  ------------------------------
   procedure Test_Get_Sizes (T : in out TesT) is
      Width  : Natural;
      Height : Natural;
   begin
      AWA.Images.Modules.Get_Sizes ("default", Width, Height);
      Util.Tests.Assert_Equals (T, 800, Width, "Default width should be 800");
      Util.Tests.Assert_Equals (T, 0, Height, "Default height should be 0");

      AWA.Images.Modules.Get_Sizes ("123x456", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 456, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("x56", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 56, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123x", Width, Height);
      Util.Tests.Assert_Equals (T, 123, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("123xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("xtoto", Width, Height);
      Util.Tests.Assert_Equals (T, 0, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, 0, Height, "Invalid height");

      AWA.Images.Modules.Get_Sizes ("original", Width, Height);
      Util.Tests.Assert_Equals (T, Natural'Last, Width, "Invalid width");
      Util.Tests.Assert_Equals (T, Natural'Last, Height, "Invalid height");
   end Test_Get_Sizes;

end AWA.Images.Modules.Tests;

Implement the Test_Get_Sizes procedure and register it for execution


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

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream from the buffer created for an output stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Output_Buffer_Stream'Class) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Buffer := From.Buffer;
      From.Buffer := null;
      Stream.Input := null;
      Stream.Read_Pos := 1;
      Stream.Write_Pos := From.Write_Pos + 1;
      Stream.Last := From.Last;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Output /= null then
         Output_Buffer_Stream'Class (Stream).Flush;
         Stream.Output.Close;
         Free_Buffer (Stream.Buffer);
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Pos := 1;
            Avail := Stream.Last - Pos + 1;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data than the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream) is
   begin
      if not Stream.No_Flush then
         if Stream.Write_Pos > 1 then
            if Stream.Output /= null then
               Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            end if;
            Stream.Write_Pos := 1;
         end if;
         if Stream.Output /= null then
            Stream.Output.Flush;
         end if;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Stream.Write_Pos > 1 then
         Into (Into'First .. Into'First + Stream.Write_Pos - 1) :=
           Stream.Buffer (Stream.Buffer'First .. Stream.Write_Pos - 1);
         Stream.Write_Pos := 1;
         Last := Into'First + Stream.Write_Pos - 1;
      else
         Last := Into'First - 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer stream to the unbounded string.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Ada.Strings.Unbounded.Set_Unbounded_String (Into, "");
      if Stream.Write_Pos > 1 then
         for I in 1 .. Stream.Write_Pos - 1 loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (I)));
         end loop;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Input_Buffer_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Buffer /= null then
         if Stream.Output /= null then
            Stream.Flush;
         end if;
         Free_Buffer (Stream.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

end Util.Streams.Buffered;

-----------------------------------------------------------------------
--  util-streams-buffered -- Buffered streams utilities
--  Copyright (C) 2010, 2011, 2013, 2014, 2016, 2017, 2018, 2019, 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 Interfaces;
with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
package body Util.Streams.Buffered is

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : access Output_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : access Input_Stream'Class;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream from the buffer created for an output stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         From    : in out Output_Buffer_Stream'Class) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Buffer := From.Buffer;
      From.Buffer := null;
      Stream.Input := null;
      Stream.Read_Pos := 1;
      Stream.Write_Pos := From.Write_Pos + 1;
      Stream.Last := From.Last;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Output /= null then
         Output_Buffer_Stream'Class (Stream).Flush;
         Stream.Output.Close;
         Free_Buffer (Stream.Buffer);
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Pos := 1;
            Avail := Stream.Last - Pos + 1;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data than the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            if Stream.Output = null then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
            Stream.Output.Write (Stream.Buffer (1 .. Pos - 1));
            Stream.Write_Pos := 1;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream) is
   begin
      if not Stream.No_Flush then
         if Stream.Write_Pos > 1 then
            if Stream.Output /= null then
               Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            end if;
            Stream.Write_Pos := 1;
         end if;
         if Stream.Output /= null then
            Stream.Output.Flush;
         end if;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      if Stream.Write_Pos > 1 then
         Into (Into'First .. Into'First + Stream.Write_Pos - 1) :=
           Stream.Buffer (Stream.Buffer'First .. Stream.Write_Pos - 1);
         Stream.Write_Pos := 1;
         Last := Into'First + Stream.Write_Pos - 1;
      else
         Last := Into'First - 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Flush the buffer stream to the unbounded string.
   --  ------------------------------
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Ada.Strings.Unbounded.Set_Unbounded_String (Into, "");
      if Stream.Write_Pos > 1 then
         for I in 1 .. Stream.Write_Pos - 1 loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (I)));
         end loop;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Input_Buffer_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Value  : out Ada.Streams.Stream_Element) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Value := Stream.Buffer (Stream.Read_Pos);
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Wide_Wide_Character) is
      use Interfaces;

      Val    : Ada.Streams.Stream_Element;
      Result : Unsigned_32;
   begin
      Stream.Read (Val);

      --  UTF-8 conversion
      --  7  U+0000   U+007F   1  0xxxxxxx
      if Val <= 16#7F# then
         Char := Wide_Wide_Character'Val (Val);

      --  11 U+0080   U+07FF   2  110xxxxx 10xxxxxx
      elsif Val <= 16#DF# then
         Result := Shift_Left (Unsigned_32 (Val and 16#1F#), 6);
         Stream.Read (Val);
         Result := Result or Unsigned_32 (Val and 16#3F#);
         Char := Wide_Wide_Character'Val (Result);

      --  16 U+0800   U+FFFF   3  1110xxxx 10xxxxxx 10xxxxxx
      elsif Val <= 16#EF# then
         Result := Shift_Left (Unsigned_32 (Val and 16#0F#), 12);
         Stream.Read (Val);
         Result := Result or Shift_Left (Unsigned_32 (Val and 16#3F#), 6);
         Stream.Read (Val);
         Result := Result or Unsigned_32 (Val and 16#3F#);
         Char := Wide_Wide_Character'Val (Result);

      --  21 U+10000  U+1FFFFF 4  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
      else
         Result := Shift_Left (Unsigned_32 (Val and 16#07#), 18);
         Stream.Read (Val);
         Result := Result or Shift_Left (Unsigned_32 (Val and 16#3F#), 12);
         Stream.Read (Val);
         Result := Result or Shift_Left (Unsigned_32 (Val and 16#3F#), 6);
         Stream.Read (Val);
         Result := Result or Unsigned_32 (Val and 16#3F#);
         Char := Wide_Wide_Character'Val (Result);
      end if;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Pos   : Stream_Element_Offset;
      Avail : Stream_Element_Offset;
      C     : Wide_Wide_Character;
   begin
      loop
         Pos := Stream.Read_Pos;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         Stream.Read (C);
         Ada.Strings.Wide_Wide_Unbounded.Append (Into, C);
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Stream : in out Output_Buffer_Stream) is
   begin
      if Stream.Buffer /= null then
         if Stream.Output /= null then
            Stream.Flush;
         end if;
         Free_Buffer (Stream.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream) is
   begin
      if Object.Buffer /= null then
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

end Util.Streams.Buffered;

Implement Read procedure to read Wide_Wide characters from UTF-8 sequences


-----------------------------------------------------------------------
--  awa-comments-beans -- Beans for the comments module
--  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 ADO.Sessions.Entities;
with ADO.Queries;
with ADO.Utils;
with AWA.Services.Contexts;
package body AWA.Comments.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "message" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "entity_id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            if Id /= ADO.NO_IDENTIFIER then
               From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
            end if;
         end;

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => Ada.Strings.Unbounded.To_String (Bean.Permission),
                                  Entity_Type => Ada.Strings.Unbounded.To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  Save the comment.
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Save;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

-----------------------------------------------------------------------
--  awa-comments-beans -- Beans for the comments module
--  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 ADO.Sessions.Entities;
with ADO.Queries;
with ADO.Utils;
with AWA.Helpers.Requests;
package body AWA.Comments.Beans is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "message" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "entity_id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            if Id /= ADO.NO_IDENTIFIER then
               From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
            end if;
         end;

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => To_String (Bean.Permission),
                                  Entity_Type => To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  Save the comment.
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Save;

   --  ------------------------------
   --  Publish or not the comment.
   --  ------------------------------
   overriding
   procedure Publish (Bean    : in out Comment_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);

      Id     : constant ADO.Identifier := Helpers.Requests.Get_Parameter ("id");
      Value  : constant Util.Beans.Objects.Object := Helpers.Requests.Get_Parameter ("status");
   begin
      Bean.Module.Publish_Comment (Permission  => To_String (Bean.Permission),
                                   Id          => Id,
                                   Status      => Models.Status_Type_Objects.To_Value (Value),
                                   Comment     => Bean);
   end Publish;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

Implement the Publish action in the comment bean


-----------------------------------------------------------------------
--  asf-servlets-rest -- REST servlet
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Rest;
with ASF.Applications;
with ASF.Streams.JSON;
with Util.Streams.Texts;
with Util.Serialize.IO.JSON;
with ASF.Routes.Servlets.Rest;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_INTERNAL_SERVER_ERROR);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Api.Descriptors (Method) = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

-----------------------------------------------------------------------
--  asf-servlets-rest -- REST servlet
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Rest;
with ASF.Applications;
with ASF.Streams.JSON;
with Util.Streams.Texts;
with Util.Serialize.IO.JSON;
with ASF.Routes.Servlets.Rest;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Api.Descriptors (Method) = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

Return a 404 error when there is no valid API rest descriptor


with Ada.Unchecked_Conversion;
with HAL.UART; use HAL.UART;
with Interfaces; use Interfaces;

package body AdaFruit.Thermal_Printer is

   function To_Char is new Ada.Unchecked_Conversion (Source => Byte,
                                                     Target => Character);
   function To_Byte is new Ada.Unchecked_Conversion (Source => Character,
                                                     Target => Byte);

   procedure Write (This : in out TP_Device; Cmd : String);
   procedure Read (This : in out TP_Device; Str : out String);

   -----------
   -- Write --
   -----------

   procedure Write (This : in out TP_Device; Cmd : String) is
      Status : UART_Status;
      Data : UART_Data_8b (Cmd'Range);
   begin

      for Index in Cmd'Range loop
         Data (Index) := To_Byte (Cmd (Index));
      end loop;

      This.Port.Transmit (Data, Status);

      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
      --  This.Time.Delay_Microseconds ((11 * 1000000 / 19_2000) + Cmd'Length);
   end Write;

   ----------
   -- Read --
   ----------

   procedure Read (This : in out TP_Device; Str : out String) is
      Status : UART_Status;
      Data : UART_Data_8b (Str'Range);
   begin
      This.Port.Receive (Data, Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;

      for Index in Str'Range loop
         Str (Index) := To_Char (Data (Index));
      end loop;
   end Read;

   ----------------------
   -- Set_Line_Spacing --
   ----------------------

   procedure Set_Line_Spacing (This : in out TP_Device; Spacing : Byte) is
   begin
      Write (This, ASCII.ESC & '3' & To_Char (Spacing));
   end Set_Line_Spacing;

   ---------------
   -- Set_Align --
   ---------------

   procedure Set_Align (This : in out TP_Device; Align : Text_Align) is
      Mode : Character;
   begin
      case Align is
         when Left   => Mode := '0';
         when Center => Mode := '1';
         when Right  => Mode := '2';
      end case;
      Write (This, ASCII.ESC & 'a' & Mode);
   end Set_Align;

   ----------------------
   -- Set_Font_Enlarge --
   ----------------------

   procedure Set_Font_Enlarge (This : in out TP_Device; Height, Width : Boolean) is
      Data : Byte := 0;
   begin
      if Height then
         Data := Data or 16#01#;
      end if;
      if Width then
         Data := Data or 16#10#;
      end if;
      Write (This, ASCII.GS & '!' & To_Char (Data));
   end Set_Font_Enlarge;

   --------------
   -- Set_Bold --
   --------------

   procedure Set_Bold (This : in out TP_Device; Bold : Boolean) is
   begin
      Write (This, ASCII.ESC & 'E' & To_Char (if Bold then 1 else 0));
   end Set_Bold;

   ----------------------
   -- Set_Double_Width --
   ----------------------

   procedure Set_Double_Width (This : in out TP_Device; Double : Boolean) is
   begin
      if Double then
         Write (This, ASCII.ESC & ASCII.SO);
      else
         Write (This, ASCII.ESC & ASCII.DC4);
      end if;
   end Set_Double_Width;

   ----------------
   -- Set_UpDown --
   ----------------

   procedure Set_UpDown (This : in out TP_Device; UpDown : Boolean) is
   begin
      Write (This, ASCII.ESC & '{' & To_Char (if UpDown then 1 else 0));
   end Set_UpDown;

   ------------------
   -- Set_Reversed --
   ------------------

   procedure Set_Reversed (This : in out TP_Device; Reversed : Boolean) is
   begin
      Write (This, ASCII.GS & 'B' & To_Char (if Reversed then 1 else 0));
   end Set_Reversed;

   --------------------------
   -- Set_Underline_Height --
   --------------------------

   procedure Set_Underline_Height (This : in out TP_Device; Height : Underline_Height) is
   begin
      Write (This, ASCII.ESC & '-' & To_Char (Height));
   end Set_Underline_Height;

   -----------------------
   -- Set_Character_Set --
   -----------------------

   procedure Set_Character_Set (This : in out TP_Device; Set : Character_Set) is
   begin
      Write (This, ASCII.ESC & 't' & To_Char (Character_Set'Pos (Set)));
   end Set_Character_Set;

   ----------
   -- Feed --
   ----------

   procedure Feed (This : in out TP_Device; Rows : Byte) is
   begin
      Write (This, ASCII.ESC & 'd' & To_Char (Rows));
   end Feed;

   ------------------
   -- Print_Bitmap --
   ------------------

   procedure Print_Bitmap (This : in out TP_Device;
                           BM   : Thermal_Printer_Bitmap)
   is
      Nbr_Of_Rows    : constant Natural := BM'Length (2);
      Nbr_Of_Columns : constant Natural := BM'Length (1);
      Str : String (1 .. Nbr_Of_Columns / 8);
   begin

      Write (This, ASCII.DC2 & 'v' &
               To_Char (Byte (Nbr_Of_Rows rem 256)) &
               To_Char (Byte (Nbr_Of_Rows / 256)));

      for Row in 0 .. Nbr_Of_Rows - 1 loop
         for Colum in 0 .. (Nbr_Of_Columns / 8) - 1 loop
            declare
               BM_Index  : constant Natural := BM'First (1) + Colum * 8;
               Str_Index : constant Natural := Str'First + Colum;
               B : Byte := 0;
            begin
               for X in 0 .. 7 loop
                  B := B or (if BM (BM_Index + X,
                                    BM'First (2) + Row)
                             then 2**X else 0);
               end loop;
               Str (Str_Index) := To_Char (B);
            end;
         end loop;
         Write (This, Str);

         --  delay until Clock + Microseconds (10000 * Str'Length);
         This.Time.Delay_Microseconds (800 * Str'Length);
      end loop;
   end Print_Bitmap;

   ----------
   -- Wake --
   ----------

   procedure Wake (This : in out TP_Device) is
   begin
      Write (This, ASCII.ESC & '@');
   end Wake;

   -----------
   -- Reset --
   -----------

   procedure Reset (This : in out TP_Device) is
   begin
      Write (This, "" & To_Char (16#FF#));
      This.Time.Delay_Milliseconds (50);

      Write (This, ASCII.ESC & '8' & ASCII.NUL & ASCII.NUL);

      for X in 1 .. 10 loop
         This.Time.Delay_Microseconds (10_000);
         Write (This, "" & ASCII.NUL);
      end loop;

   end Reset;

   -----------
   -- Print --
   -----------

   procedure Print (This : in out TP_Device; Text : String) is
   begin
      Write (This, Text);
   end Print;

   ----------------
   -- Get_Status --
   ----------------

   function Get_Status (This : in out TP_Device) return Printer_Status is
      Ret : Printer_Status;
      Status : String := "P1V72T30";
   begin
      Ret.Paper := False;
      Ret.Voltage := 0;
      Ret.Temperature := 0;
      Write (This, ASCII.ESC & 'v');
      Read (This, Status);

      --  Parse status here
      --  P<Paper>V<Voltage>T<Degree>
      --  Example: P1V72T30 Mean:Paper Ready,Current voltage 7.2V,Printer degree:30

      return Ret;
   end Get_Status;

   --------------------------
   -- Set_Printer_Settings --
   --------------------------

   procedure Set_Printer_Settings (This : in out TP_Device; Settings : Printer_Settings) is
   begin
      Write (This, ASCII.ESC & '7'
             & To_Char (Settings.Max_Printing_Dots)
             & To_Char (if Settings.Heating_Time < 3
               then 3 else Settings.Heating_Time)
             & To_Char (Settings.Heating_Interval));
   end Set_Printer_Settings;

   -----------------
   -- Set_Density --
   -----------------

   procedure Set_Density (This : in out TP_Device; Density, Breaktime : Byte) is
   begin
      Write (This,
             ASCII.DC2 & '#' & To_Char (Shift_Left (Breaktime, 5) or Density));
   end Set_Density;

   ---------------------
   -- Print_Test_Page --
   ---------------------

   procedure Print_Test_Page (This : in out TP_Device) is
   begin
      Write (This, ASCII.DC2 & 'T');
   end Print_Test_Page;

end AdaFruit.Thermal_Printer;

with Ada.Unchecked_Conversion;
with HAL.UART; use HAL.UART;
with Interfaces; use Interfaces;

package body AdaFruit.Thermal_Printer is

   function To_Char is new Ada.Unchecked_Conversion (Source => Byte,
                                                     Target => Character);
   function To_Byte is new Ada.Unchecked_Conversion (Source => Character,
                                                     Target => Byte);

   procedure Write (This : in out TP_Device; Cmd : String);
   procedure Read (This : in out TP_Device; Str : out String);

   -----------
   -- Write --
   -----------

   procedure Write (This : in out TP_Device; Cmd : String) is
      Status : UART_Status;
      Data : UART_Data_8b (Cmd'Range);
   begin

      for Index in Cmd'Range loop
         Data (Index) := To_Byte (Cmd (Index));
      end loop;

      This.Port.Transmit (Data, Status);

      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;
      --  This.Time.Delay_Microseconds ((11 * 1000000 / 19_2000) + Cmd'Length);
   end Write;

   ----------
   -- Read --
   ----------

   procedure Read (This : in out TP_Device; Str : out String) is
      Status : UART_Status;
      Data : UART_Data_8b (Str'Range);
   begin
      This.Port.Receive (Data, Status);
      if Status /= Ok then
         --  No error handling...
         raise Program_Error;
      end if;

      for Index in Str'Range loop
         Str (Index) := To_Char (Data (Index));
      end loop;
   end Read;

   ----------------------
   -- Set_Line_Spacing --
   ----------------------

   procedure Set_Line_Spacing (This : in out TP_Device; Spacing : Byte) is
   begin
      Write (This, ASCII.ESC & '3' & To_Char (Spacing));
   end Set_Line_Spacing;

   ---------------
   -- Set_Align --
   ---------------

   procedure Set_Align (This : in out TP_Device; Align : Text_Align) is
      Mode : Character;
   begin
      case Align is
         when Left   => Mode := '0';
         when Center => Mode := '1';
         when Right  => Mode := '2';
      end case;
      Write (This, ASCII.ESC & 'a' & Mode);
   end Set_Align;

   ----------------------
   -- Set_Font_Enlarge --
   ----------------------

   procedure Set_Font_Enlarge (This : in out TP_Device; Height, Width : Boolean) is
      Data : Byte := 0;
   begin
      if Height then
         Data := Data or 16#01#;
      end if;
      if Width then
         Data := Data or 16#10#;
      end if;
      Write (This, ASCII.GS & '!' & To_Char (Data));
   end Set_Font_Enlarge;

   --------------
   -- Set_Bold --
   --------------

   procedure Set_Bold (This : in out TP_Device; Bold : Boolean) is
   begin
      Write (This, ASCII.ESC & 'E' & To_Char (if Bold then 1 else 0));
   end Set_Bold;

   ----------------------
   -- Set_Double_Width --
   ----------------------

   procedure Set_Double_Width (This : in out TP_Device; Double : Boolean) is
   begin
      if Double then
         Write (This, ASCII.ESC & ASCII.SO);
      else
         Write (This, ASCII.ESC & ASCII.DC4);
      end if;
   end Set_Double_Width;

   ----------------
   -- Set_UpDown --
   ----------------

   procedure Set_UpDown (This : in out TP_Device; UpDown : Boolean) is
   begin
      Write (This, ASCII.ESC & '{' & To_Char (if UpDown then 1 else 0));
   end Set_UpDown;

   ------------------
   -- Set_Reversed --
   ------------------

   procedure Set_Reversed (This : in out TP_Device; Reversed : Boolean) is
   begin
      Write (This, ASCII.GS & 'B' & To_Char (if Reversed then 1 else 0));
   end Set_Reversed;

   --------------------------
   -- Set_Underline_Height --
   --------------------------

   procedure Set_Underline_Height (This : in out TP_Device; Height : Underline_Height) is
   begin
      Write (This, ASCII.ESC & '-' & To_Char (Height));
   end Set_Underline_Height;

   -----------------------
   -- Set_Character_Set --
   -----------------------

   procedure Set_Character_Set (This : in out TP_Device; Set : Character_Set) is
   begin
      Write (This, ASCII.ESC & 't' & To_Char (Character_Set'Pos (Set)));
   end Set_Character_Set;

   ----------
   -- Feed --
   ----------

   procedure Feed (This : in out TP_Device; Rows : Byte) is
   begin
      Write (This, ASCII.ESC & 'd' & To_Char (Rows));
   end Feed;

   ------------------
   -- Print_Bitmap --
   ------------------

   procedure Print_Bitmap (This : in out TP_Device;
                           BM   : Thermal_Printer_Bitmap)
   is
      Nbr_Of_Rows    : constant Natural := BM'Length (2);
      Nbr_Of_Columns : constant Natural := BM'Length (1);
      Str : String (1 .. Nbr_Of_Columns / 8);
   begin

      Write (This, ASCII.DC2 & 'v' &
               To_Char (Byte (Nbr_Of_Rows rem 256)) &
               To_Char (Byte (Nbr_Of_Rows / 256)));

      for Row in 0 .. Nbr_Of_Rows - 1 loop
         for Colum in 0 .. (Nbr_Of_Columns / 8) - 1 loop
            declare
               BM_Index  : constant Natural := BM'First (1) + Colum * 8;
               Str_Index : constant Natural := Str'First + Colum;
               B : Byte := 0;
            begin
               for X in 0 .. 7 loop
                  B := B or (if BM (BM_Index + X,
                                    BM'First (2) + Row)
                             then 2**X else 0);
               end loop;
               Str (Str_Index) := To_Char (B);
            end;
         end loop;
         Write (This, Str);

         --  delay until Clock + Microseconds (10000 * Str'Length);
         This.Time.Delay_Microseconds (600 * Str'Length);
      end loop;
   end Print_Bitmap;

   ----------
   -- Wake --
   ----------

   procedure Wake (This : in out TP_Device) is
   begin
      Write (This, ASCII.ESC & '@');
   end Wake;

   -----------
   -- Reset --
   -----------

   procedure Reset (This : in out TP_Device) is
   begin
      Write (This, "" & To_Char (16#FF#));
      This.Time.Delay_Milliseconds (50);

      Write (This, ASCII.ESC & '8' & ASCII.NUL & ASCII.NUL);

      for X in 1 .. 10 loop
         This.Time.Delay_Microseconds (10_000);
         Write (This, "" & ASCII.NUL);
      end loop;

   end Reset;

   -----------
   -- Print --
   -----------

   procedure Print (This : in out TP_Device; Text : String) is
   begin
      Write (This, Text);
   end Print;

   ----------------
   -- Get_Status --
   ----------------

   function Get_Status (This : in out TP_Device) return Printer_Status is
      Ret : Printer_Status;
      Status : String := "P1V72T30";
   begin
      Ret.Paper := False;
      Ret.Voltage := 0;
      Ret.Temperature := 0;
      Write (This, ASCII.ESC & 'v');
      Read (This, Status);

      --  Parse status here
      --  P<Paper>V<Voltage>T<Degree>
      --  Example: P1V72T30 Mean:Paper Ready,Current voltage 7.2V,Printer degree:30

      return Ret;
   end Get_Status;

   --------------------------
   -- Set_Printer_Settings --
   --------------------------

   procedure Set_Printer_Settings (This : in out TP_Device; Settings : Printer_Settings) is
   begin
      Write (This, ASCII.ESC & '7'
             & To_Char (Settings.Max_Printing_Dots)
             & To_Char (if Settings.Heating_Time < 3
               then 3 else Settings.Heating_Time)
             & To_Char (Settings.Heating_Interval));
   end Set_Printer_Settings;

   -----------------
   -- Set_Density --
   -----------------

   procedure Set_Density (This : in out TP_Device; Density, Breaktime : Byte) is
   begin
      Write (This,
             ASCII.DC2 & '#' & To_Char (Shift_Left (Breaktime, 5) or Density));
   end Set_Density;

   ---------------------
   -- Print_Test_Page --
   ---------------------

   procedure Print_Test_Page (This : in out TP_Device) is
   begin
      Write (This, ASCII.DC2 & 'T');
   end Print_Test_Page;

end AdaFruit.Thermal_Printer;

Increase bitmap print speed

AdaFruit.Thermal_Printer: Increase bitmap print speed