-----------------------------------------------------------------------
--  util-encodes-tests - Test for encoding
--  Copyright (C) 2009, 2010 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.Tests;
with Util.Measures;
with Util.Strings.Transforms;
with Ada.Text_IO;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
--  with Util.Log.Loggers;
package body Util.Encoders.Tests is

   use Util.Tests;
--     use Util.Log;
--
--     Log : constant Loggers.Logger := Loggers.Create ("Util.Encoders.Tests");

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Encode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Decode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Encode",
                       Test_Base64_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Decode",
                       Test_Base64_Decode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Benchmark",
                       Test_Base64_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Encode",
                       Test_SHA1_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Benchmark",
                       Test_SHA1_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test1)",
                       Test_HMAC_SHA1_RFC2202_T1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test2)",
                       Test_HMAC_SHA1_RFC2202_T2'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test3)",
                       Test_HMAC_SHA1_RFC2202_T3'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test4)",
                       Test_HMAC_SHA1_RFC2202_T4'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test5)",
                       Test_HMAC_SHA1_RFC2202_T5'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test6)",
                       Test_HMAC_SHA1_RFC2202_T6'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test7)",
                       Test_HMAC_SHA1_RFC2202_T7'Access);
   end Add_Tests;

   procedure Test_Base64_Encode (T : in out Test) is
      C : constant Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "YQ==", Util.Encoders.Encode (C, "a"));
      Assert_Equals (T, "fA==", Util.Encoders.Encode (C, "|"));
      Assert_Equals (T, "fHw=", Util.Encoders.Encode (C, "||"));
      Assert_Equals (T, "fH5+", Util.Encoders.Encode (C, "|~~"));
   end Test_Base64_Encode;

   procedure Test_Base64_Decode (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "a", Util.Encoders.Decode (C, "YQ=="));
      Assert_Equals (T, "|", Util.Encoders.Decode (C, "fA=="));
      Assert_Equals (T, "||", Util.Encoders.Decode (C, "fHw="));
      Assert_Equals (T, "|~~", Util.Encoders.Decode (C, "fH5+"));
      Test_Encoder (T, C);
   end Test_Base64_Decode;

   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder) is
   begin
      for I in 1 .. 334 loop
         declare
            Pattern : String (1 .. I);
         begin
            for J in Pattern'Range loop
               Pattern (J) := Character'Val (((J + I) mod 63) + 32);
            end loop;
            declare
               E : constant String := Util.Encoders.Encode (C, Pattern);
               D : constant String := Util.Encoders.Decode (C, E);
            begin
               Assert_Equals (T, Pattern, D, "Encoding failed for length "
                              & Integer'Image (I));
            end;
         exception
            when others =>
               Ada.Text_IO.Put_Line ("Error at index " & Integer'Image (I));
               raise;
         end;
      end loop;
   end Test_Encoder;

   procedure Test_Hex (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("hex");
   begin
      Assert_Equals (T, "41424344", Util.Encoders.Encode(C, "ABCD"));
      Assert_Equals (T, "ABCD", Util.Encoders.Decode (C, "41424344"));
      Test_Encoder (T, C);
   end Test_Hex;

   procedure Test_Base64_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      C : constant Util.Encoders.Encoder := Create ("base64");
      S : constant String (1 .. 1_024) := (others => 'a');
   begin
      declare
         T : Util.Measures.Stamp;
         R : constant String := Util.Encoders.Encode (C, S);
         pragma Unreferenced (R);
      begin
         Util.Measures.Report (T, "Base64 encode 1024 bytes");
      end;
   end Test_Base64_Benchmark;

   procedure Test_SHA1_Encode (T : in out Test) is
      C    : Util.Encoders.SHA1.Context;
      Hash : Util.Encoders.SHA1.Digest;

      procedure Check_Hash (Value  : in String;
                            Expect : in String) is
         J, N : Natural;
         Ctx  : Util.Encoders.SHA1.Context;
      begin
         for I in 1 .. Value'Length loop
            J := Value'First;
            while J <= Value'Last loop
               if J + I <= Value'Last then
                  N := J + I;
               else
                  N := Value'Last;
               end if;
               Util.Encoders.SHA1.Update (Ctx, Value (J .. N));
               J := N + 1;
            end loop;
            Util.Encoders.SHA1.Finish (Ctx, Hash);
            Assert_Equals (T, Expect, Hash, "Invalid hash for: " & Value);
         end loop;
      end Check_Hash;

   begin
      Util.Encoders.SHA1.Update (C, "a");
      Util.Encoders.SHA1.Finish (C, Hash);

      Assert_Equals (T, "86F7E437FAA5A7FCE15D1DDCB9EAEAEA377667B8", Hash,
                     "Invalid hash for 'a'");

      Check_Hash ("ut", "E746699D3947443D84DAD1E0C58BF7AD34712438");
      Check_Hash ("Uti", "2C669751BDC4929377245F5EEBEAED1CE4DA8A45");
      Check_Hash ("Util", "4C31156EFED35EE7814650F8971C3698059440E3");
      Check_Hash ("Util.Encoders", "7DB6007AD8BAEA7C167FF2AE06C9F50A4645F971");
      Check_Hash ("e746699d3947443d84dad1e0c58bf7ad347124382C669751BDC492937"
                  & "7245F5EEBEAED1CE4DA8A45",
                  "875C9C0DE4CE91ED8F432DD02B5BB40CD35DAACD");
   end Test_SHA1_Encode;

   --  ------------------------------
   --  Benchmark test for SHA1
   --  ------------------------------
   procedure Test_SHA1_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      Hash  : Util.Encoders.SHA1.Digest;
      Sizes : constant array (1 .. 6) of Positive := (1, 10, 100, 1000, 10000, 100000);
   begin
      for I in Sizes'Range loop
         declare
            Size : constant Positive := Sizes (I);
            S    : constant String (1 .. Size) := (others => '0');
            T1   : Util.Measures.Stamp;
            C    : Util.Encoders.SHA1.Context;
         begin
            Util.Encoders.SHA1.Update (C, S);
            Util.Encoders.SHA1.Finish (C, Hash);

            Util.Measures.Report (T1, "Encode SHA1" & Integer'Image (Size) & " bytes");
         end;
      end loop;
   end Test_SHA1_Benchmark;

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String) is
      H : constant String := Util.Encoders.HMAC.SHA1.Sign (Key, Value);
   begin
      Assert_Equals (T, Expect, Util.Strings.Transforms.To_Lower_Case (H),
                     "Invalid HMAC-SHA1");
   end Check_HMAC;

   --  ------------------------------
   --  Test HMAC-SHA1
   --  ------------------------------
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test) is
      Key : constant String (1 .. 20) := (others => Character'Val (16#0b#));
   begin
      Check_HMAC (T, Key, "Hi There", "b617318655057264e28bc0b6fb378c8ef146be00");
   end Test_HMAC_SHA1_RFC2202_T1;

   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test) is
   begin
      Check_HMAC (T, "Jefe", "what do ya want for nothing?",
                  "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79");
   end Test_HMAC_SHA1_RFC2202_T2;

   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#aa#));
      Data : constant String (1 .. 50) := (others => Character'Val (16#dd#));
   begin
      Check_HMAC (T, Key, Data,
                  "125d7342b9ac11cd91a39af48aa17b4f63f175d3");
   end Test_HMAC_SHA1_RFC2202_T3;

   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test) is
      C    : constant Util.Encoders.Encoder := Create ("hex");
      Key  : constant String := Util.Encoders.Decode (C, "0102030405060708090a0b0c0d0e0f10111213141516171819");
      Data : constant String (1 .. 50) := (others => Character'Val (16#cd#));
   begin
      Check_HMAC (T, Key, Data,
                  "4c9007f4026250c6bc8414f9bf50c86c2d7235da");
   end Test_HMAC_SHA1_RFC2202_T4;

   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#0c#));
   begin
      --  RFC2202 test case 5 but without truncation...
      Check_HMAC (T, Key, "Test With Truncation",
                  "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04");
   end Test_HMAC_SHA1_RFC2202_T5;

   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key - Hash Key First",
                  "aa4ae5e15272d00e95705637ce8a3b55ed402112");
   end Test_HMAC_SHA1_RFC2202_T6;

   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#Aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key and Larger "
                    & "Than One Block-Size Data",
                  "e8e99d0f45237d786d6bbaa7965c7808bbff1a91");
   end Test_HMAC_SHA1_RFC2202_T7;

end Util.Encoders.Tests;

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

with Util.Test_Caller;
with Util.Measures;
with Util.Strings.Transforms;
with Ada.Text_IO;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
package body Util.Encoders.Tests is

   use Util.Tests;
--     use Util.Log;
--
--     Log : constant Loggers.Logger := Loggers.Create ("Util.Encoders.Tests");

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Encode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Decode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Encode",
                       Test_Base64_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Decode",
                       Test_Base64_Decode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Benchmark",
                       Test_Base64_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Encode",
                       Test_SHA1_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Benchmark",
                       Test_SHA1_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test1)",
                       Test_HMAC_SHA1_RFC2202_T1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test2)",
                       Test_HMAC_SHA1_RFC2202_T2'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test3)",
                       Test_HMAC_SHA1_RFC2202_T3'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test4)",
                       Test_HMAC_SHA1_RFC2202_T4'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test5)",
                       Test_HMAC_SHA1_RFC2202_T5'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test6)",
                       Test_HMAC_SHA1_RFC2202_T6'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test7)",
                       Test_HMAC_SHA1_RFC2202_T7'Access);
   end Add_Tests;

   procedure Test_Base64_Encode (T : in out Test) is
      C : constant Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "YQ==", Util.Encoders.Encode (C, "a"));
      Assert_Equals (T, "fA==", Util.Encoders.Encode (C, "|"));
      Assert_Equals (T, "fHw=", Util.Encoders.Encode (C, "||"));
      Assert_Equals (T, "fH5+", Util.Encoders.Encode (C, "|~~"));
   end Test_Base64_Encode;

   procedure Test_Base64_Decode (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "a", Util.Encoders.Decode (C, "YQ=="));
      Assert_Equals (T, "|", Util.Encoders.Decode (C, "fA=="));
      Assert_Equals (T, "||", Util.Encoders.Decode (C, "fHw="));
      Assert_Equals (T, "|~~", Util.Encoders.Decode (C, "fH5+"));
      Test_Encoder (T, C);
   end Test_Base64_Decode;

   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder) is
   begin
      for I in 1 .. 334 loop
         declare
            Pattern : String (1 .. I);
         begin
            for J in Pattern'Range loop
               Pattern (J) := Character'Val (((J + I) mod 63) + 32);
            end loop;
            declare
               E : constant String := Util.Encoders.Encode (C, Pattern);
               D : constant String := Util.Encoders.Decode (C, E);
            begin
               Assert_Equals (T, Pattern, D, "Encoding failed for length "
                              & Integer'Image (I));
            end;
         exception
            when others =>
               Ada.Text_IO.Put_Line ("Error at index " & Integer'Image (I));
               raise;
         end;
      end loop;
   end Test_Encoder;

   procedure Test_Hex (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("hex");
   begin
      Assert_Equals (T, "41424344", Util.Encoders.Encode (C, "ABCD"));
      Assert_Equals (T, "ABCD", Util.Encoders.Decode (C, "41424344"));
      Test_Encoder (T, C);
   end Test_Hex;

   procedure Test_Base64_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      C : constant Util.Encoders.Encoder := Create ("base64");
      S : constant String (1 .. 1_024) := (others => 'a');
   begin
      declare
         T : Util.Measures.Stamp;
         R : constant String := Util.Encoders.Encode (C, S);
         pragma Unreferenced (R);
      begin
         Util.Measures.Report (T, "Base64 encode 1024 bytes");
      end;
   end Test_Base64_Benchmark;

   procedure Test_SHA1_Encode (T : in out Test) is
      procedure Check_Hash (Value  : in String;
                            Expect : in String);

      C    : Util.Encoders.SHA1.Context;
      Hash : Util.Encoders.SHA1.Digest;

      procedure Check_Hash (Value  : in String;
                            Expect : in String) is
         J, N : Natural;
         Ctx  : Util.Encoders.SHA1.Context;
      begin
         for I in 1 .. Value'Length loop
            J := Value'First;
            while J <= Value'Last loop
               if J + I <= Value'Last then
                  N := J + I;
               else
                  N := Value'Last;
               end if;
               Util.Encoders.SHA1.Update (Ctx, Value (J .. N));
               J := N + 1;
            end loop;
            Util.Encoders.SHA1.Finish (Ctx, Hash);
            Assert_Equals (T, Expect, Hash, "Invalid hash for: " & Value);
         end loop;
      end Check_Hash;

   begin
      Util.Encoders.SHA1.Update (C, "a");
      Util.Encoders.SHA1.Finish (C, Hash);

      Assert_Equals (T, "86F7E437FAA5A7FCE15D1DDCB9EAEAEA377667B8", Hash,
                     "Invalid hash for 'a'");

      Check_Hash ("ut", "E746699D3947443D84DAD1E0C58BF7AD34712438");
      Check_Hash ("Uti", "2C669751BDC4929377245F5EEBEAED1CE4DA8A45");
      Check_Hash ("Util", "4C31156EFED35EE7814650F8971C3698059440E3");
      Check_Hash ("Util.Encoders", "7DB6007AD8BAEA7C167FF2AE06C9F50A4645F971");
      Check_Hash ("e746699d3947443d84dad1e0c58bf7ad347124382C669751BDC492937"
                  & "7245F5EEBEAED1CE4DA8A45",
                  "875C9C0DE4CE91ED8F432DD02B5BB40CD35DAACD");
   end Test_SHA1_Encode;

   --  ------------------------------
   --  Benchmark test for SHA1
   --  ------------------------------
   procedure Test_SHA1_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      Hash  : Util.Encoders.SHA1.Digest;
      Sizes : constant array (1 .. 6) of Positive := (1, 10, 100, 1000, 10000, 100000);
   begin
      for I in Sizes'Range loop
         declare
            Size : constant Positive := Sizes (I);
            S    : constant String (1 .. Size) := (others => '0');
            T1   : Util.Measures.Stamp;
            C    : Util.Encoders.SHA1.Context;
         begin
            Util.Encoders.SHA1.Update (C, S);
            Util.Encoders.SHA1.Finish (C, Hash);

            Util.Measures.Report (T1, "Encode SHA1" & Integer'Image (Size) & " bytes");
         end;
      end loop;
   end Test_SHA1_Benchmark;

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String) is
      H : constant String := Util.Encoders.HMAC.SHA1.Sign (Key, Value);
   begin
      Assert_Equals (T, Expect, Util.Strings.Transforms.To_Lower_Case (H),
                     "Invalid HMAC-SHA1");
   end Check_HMAC;

   --  ------------------------------
   --  Test HMAC-SHA1
   --  ------------------------------
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test) is
      Key : constant String (1 .. 20) := (others => Character'Val (16#0b#));
   begin
      Check_HMAC (T, Key, "Hi There", "b617318655057264e28bc0b6fb378c8ef146be00");
   end Test_HMAC_SHA1_RFC2202_T1;

   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test) is
   begin
      Check_HMAC (T, "Jefe", "what do ya want for nothing?",
                  "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79");
   end Test_HMAC_SHA1_RFC2202_T2;

   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#aa#));
      Data : constant String (1 .. 50) := (others => Character'Val (16#dd#));
   begin
      Check_HMAC (T, Key, Data,
                  "125d7342b9ac11cd91a39af48aa17b4f63f175d3");
   end Test_HMAC_SHA1_RFC2202_T3;

   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test) is
      C    : constant Util.Encoders.Encoder := Create ("hex");
      Key  : constant String := Util.Encoders.Decode (C, "0102030405060708090a0b0c0d0e0f"
                                                      & "10111213141516171819");
      Data : constant String (1 .. 50) := (others => Character'Val (16#cd#));
   begin
      Check_HMAC (T, Key, Data,
                  "4c9007f4026250c6bc8414f9bf50c86c2d7235da");
   end Test_HMAC_SHA1_RFC2202_T4;

   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#0c#));
   begin
      --  RFC2202 test case 5 but without truncation...
      Check_HMAC (T, Key, "Test With Truncation",
                  "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04");
   end Test_HMAC_SHA1_RFC2202_T5;

   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key - Hash Key First",
                  "aa4ae5e15272d00e95705637ce8a3b55ed402112");
   end Test_HMAC_SHA1_RFC2202_T6;

   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#Aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key and Larger "
                    & "Than One Block-Size Data",
                  "e8e99d0f45237d786d6bbaa7965c7808bbff1a91");
   end Test_HMAC_SHA1_RFC2202_T7;

end Util.Encoders.Tests;

Fix compilation warnings

Fix compilation warnings


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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;
with Util.Systems.Types;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type File_Type is new Integer;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer;
   pragma Import (C, Close, "close");

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T;
   pragma Import (C, Read, "read");

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T;
   pragma Import (C, Write, "write");

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer);
   pragma Import (C, Sys_Exit, "_exit");

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_Fork, "fork");

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_VFork, "fork");

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer;
   pragma Import (C, Sys_Execvp, "execvp");

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer;
   pragma Import (C, Sys_Waitpid, "waitpid");

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer;
   pragma Import (C, Sys_Pipe, "pipe");

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer;
   pragma Import (C, Sys_Dup2, "dup2");

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;
   pragma Import (C, Sys_Close, "close");

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Interfaces.C.int) return File_Type;
   pragma Import (C, Sys_Open, "open");

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer;
   pragma Import (C, Sys_Fcntl, "fcntl");

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer;
   pragma Import (C, Sys_Kill, "kill");

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Stat, Util.Systems.Types.STAT_NAME);

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Fstat, Util.Systems.Types.FSTAT_NAME);

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode) return Util.Systems.Types.off_t;
   pragma Import (C, Sys_Lseek, "lseek");

end Util.Systems.Os;

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

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;
with Util.Systems.Types;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type File_Type is new Integer;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer;
   pragma Import (C, Close, "close");

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T;
   pragma Import (C, Read, "read");

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T;
   pragma Import (C, Write, "write");

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer);
   pragma Import (C, Sys_Exit, "_exit");

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_Fork, "fork");

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_VFork, "fork");

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer;
   pragma Import (C, Sys_Execvp, "execvp");

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer;
   pragma Import (C, Sys_Waitpid, "waitpid");

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer;
   pragma Import (C, Sys_Pipe, "pipe");

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer;
   pragma Import (C, Sys_Dup2, "dup2");

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;
   pragma Import (C, Sys_Close, "close");

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type;
   pragma Import (C, Sys_Open, "open");

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer;
   pragma Import (C, Sys_Fcntl, "fcntl");

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer;
   pragma Import (C, Sys_Kill, "kill");

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Stat, Util.Systems.Types.STAT_NAME);

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Fstat, Util.Systems.Types.FSTAT_NAME);

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode) return Util.Systems.Types.off_t;
   pragma Import (C, Sys_Lseek, "lseek");

   --  Libc errno.  The __get_errno function is provided by the GNAT runtime.
   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

end Util.Systems.Os;

Declare the Errno function

Declare the Errno function


-----------------------------------------------------------------------
--  awa-commands-tests -- Test the AWA.Commands
--  Copyright (C) 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Commands.Tests is

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

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

   --  Test start and stop command.
   procedure Test_Start_Stop (T : in out Test);

   procedure Test_List_Tables (T : in out Test);

   --  Test the list -u command.
   procedure Test_List_Users (T : in out Test);

   --  Test the list -s command.
   procedure Test_List_Sessions (T : in out Test);

   --  Test the list -j command.
   procedure Test_List_Jobs (T : in out Test);

   --  Test the command with a secure keystore configuration.
   procedure Test_Secure_Configuration (T : in out Test);

   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

end AWA.Commands.Tests;

-----------------------------------------------------------------------
--  awa-commands-tests -- Test the AWA.Commands
--  Copyright (C) 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.Tests;
with Ada.Strings.Unbounded;

package AWA.Commands.Tests is

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

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

   --  Test start and stop command.
   procedure Test_Start_Stop (T : in out Test);

   procedure Test_List_Tables (T : in out Test);

   --  Test the list -u command.
   procedure Test_List_Users (T : in out Test);

   --  Test the list -s command.
   procedure Test_List_Sessions (T : in out Test);

   --  Test the list -j command.
   procedure Test_List_Jobs (T : in out Test);

   --  Test the command with a secure keystore configuration.
   procedure Test_Secure_Configuration (T : in out Test);

   --  Test the command with various logging options.
   procedure Test_Verbose_Command (T : in out Test);

   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

end AWA.Commands.Tests;

Declare Test_Verbose_Command procedure

Declare Test_Verbose_Command procedure


with C_String.Arrays;
with C_String;
with Interfaces.C;

package body Jack.Client is
  package C renames Interfaces.C;

  use type Thin.Status_t;
  use type System.Address;

  --
  -- Activate
  --

  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean)
  is
    C_Return : constant C.int := Thin.Activate (System.Address (Client));
  begin
    Failed := C_Return /= 0;
  end Activate;

  --
  -- Get_Ports
  --

  procedure Get_Ports_Free (Data : System.Address);
  pragma Import (C, Get_Ports_Free, "jack_ada_client_get_ports_free");

  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String;
     Port_Type_Pattern : in     String;
     Port_Flags        : in     Port_Flags_t;
     Ports             :    out Port_Name_Set_t)
  is
    Name    : Port_Name_t;
    Size    : Natural;
    C_Flags : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name  : aliased C.char_array       := C.To_C (Port_Name_Pattern);
    C_Type  : aliased C.char_array       := C.To_C (Port_Type_Pattern);
    Address : constant C_String.Arrays.Pointer_Array_t :=
      Thin.Get_Ports
        (Client            => System.Address (Client),
         Port_Name_Pattern => C_String.To_C_String (C_Name'Unchecked_Access),
         Type_Name_Pattern => C_String.To_C_String (C_Type'Unchecked_Access),
         Flags             => C_Flags);
  begin
    Size := C_String.Arrays.Size_Terminated (Address);

    for Index in 0 .. Size loop
      Port_Names.Set_Bounded_String
        (Source => C_String.Arrays.Index_Terminated (Address, Index),
         Target => Name);
      Port_Name_Sets.Insert (Ports, Name);
    end loop;

    -- The strings returned by jack_get_ports are heap allocated.
    Get_Ports_Free (System.Address (Address));
  end Get_Ports;

  --
  -- Status, option and flag mapping.
  --

  type Status_Map_t is array (Status_Selector_t) of Thin.Status_t;

  Status_Map : constant Status_Map_t := Status_Map_t'
    (Failure               => Thin.JackFailure,
     Invalid_Option        => Thin.JackInvalidOption,
     Name_Not_Unique       => Thin.JackNameNotUnique,
     Server_Started        => Thin.JackServerStarted,
     Server_Failed         => Thin.JackServerFailed,
     Server_Error          => Thin.JackServerError,
     No_Such_Client        => Thin.JackNoSuchClient,
     Load_Failure          => Thin.JackLoadFailure,
     Init_Failure          => Thin.JackInitFailure,
     Shared_Memory_Failure => Thin.JackShmFailure,
     Version_Error         => Thin.JackVersionError);

  type Options_Map_t is array (Option_Selector_t) of Thin.Options_t;

  Options_Map : constant Options_Map_t := Options_Map_t'
    (Do_Not_Start_Server => Thin.JackNoStartServer,
     Use_Exact_Name      => Thin.JackUseExactName,
     Server_Name         => Thin.JackServerName,
     Load_Name           => Thin.JackLoadName,
     Load_Initialize     => Thin.JackLoadInit);

  type Port_Flags_Map_t is array (Port_Flag_Selector_t) of Thin.Port_Flags_t;

  Port_Flags_Map : constant Port_Flags_Map_t := Port_Flags_Map_t'
    (Port_Is_Input    => Thin.JackPortIsInput,
     Port_Is_Output   => Thin.JackPortIsOutput,
     Port_Is_Physical => Thin.JackPortIsPhysical,
     Port_Can_Monitor => Thin.JackPortCanMonitor,
     Port_Is_Terminal => Thin.JackPortIsTerminal);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t is
    Return_Options : Thin.Options_t := 0;
  begin
    for Selector in Options_t'Range loop
      if Options (Selector) then
        Return_Options := Return_Options or Options_Map (Selector);
      end if;
    end loop;
    return Return_Options;
  end Map_Options_To_Thin;

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t is
    Return_Port_Flags : Thin.Port_Flags_t := 0;
  begin
    for Selector in Port_Flags_t'Range loop
      if Port_Flags (Selector) then
        Return_Port_Flags := Return_Port_Flags or Port_Flags_Map (Selector);
      end if;
    end loop;
    return Return_Port_Flags;
  end Map_Port_Flags_To_Thin;

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t is
    Return_Status : Thin.Status_t := 0;
  begin
    for Selector in Status_t'Range loop
      if Status (Selector) then
        Return_Status := Return_Status or Status_Map (Selector);
      end if;
    end loop;
    return Return_Status;
  end Map_Status_To_Thin;

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t is
    Return_Options : Options_t := (others => False);
  begin
    for Selector in Options_t'Range loop
      Return_Options (Selector) :=
        (Options and Options_Map (Selector)) = Options_Map (Selector);
    end loop;
    return Return_Options;
  end Map_Thin_To_Options;

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t is
    Return_Port_Flags : Port_Flags_t := (others => False);
  begin
    for Selector in Port_Flags_t'Range loop
      Return_Port_Flags (Selector) :=
        (Port_Flags and Port_Flags_Map (Selector)) = Port_Flags_Map (Selector);
    end loop;
    return Return_Port_Flags;
  end Map_Thin_To_Port_Flags;

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t is
    Return_Status : Status_t := (others => False);
  begin
    for Selector in Status_t'Range loop
      Return_Status (Selector) :=
        (Status and Status_Map (Selector)) = Status_Map (Selector);
    end loop;
    return Return_Status;
  end Map_Thin_To_Status;

  --
  -- Open
  --

  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t)
  is
    C_Options : constant Thin.Options_t := Map_Options_To_Thin (Options);
    C_Name    : aliased C.char_array   := C.To_C (Client_Name);
    C_Status  : aliased Thin.Status_t;
    C_Client  : System.Address;
  begin
    C_Client := Thin.Client_Open
      (Client_Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Options     => C_Options,
       Status      => C_Status'Address);
    Status := Map_Thin_To_Status (C_Status);

    if C_Client = System.Null_Address then
      Client := Invalid_Client;
    else
      Client := Client_t (C_Client);
    end if;
  end Open;

  --
  -- Port_Name_Size
  --

  function Port_Name_Size return Natural is
  begin
    return Natural (Thin.Port_Name_Size);
  end Port_Name_Size;

  --
  -- Port_Register
  --

  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String;
     Port_Flags  : in     Port_Flags_t;
     Buffer_Size : in     Natural := 0)
  is
    C_Flags : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name  : aliased C.char_array       := C.To_C (Port_Names.To_String (Port_Name));
    C_Port  : System.Address;
    C_Type  : aliased C.char_array       := C.To_C (Port_Type);
  begin
    C_Port := Thin.Port_Register
      (Client      => System.Address (Client),
       Port_Name   => C_String.To_C_String (C_Name'Unchecked_Access),
       Port_Type   => C_String.To_C_String (C_Type'Unchecked_Access),
       Flags       => C_Flags,
       Buffer_Size => C.unsigned_long (Buffer_Size));

    if C_Port = System.Null_Address then
      Port := Invalid_Port;
    else
      Port := Port_t (C_Port);
    end if;
  end Port_Register;

end Jack.Client;

with C_String.Arrays;
with C_String;
with Interfaces.C;

package body Jack.Client is
  package C renames Interfaces.C;

  use type C.int;
  use type System.Address;
  use type Thin.Port_Flags_t;
  use type Thin.Status_t;

  --
  -- Activate
  --

  procedure Activate
    (Client : in     Client_t;
     Failed :    out Boolean)
  is
    C_Return : constant C.int := Thin.Activate (System.Address (Client));
  begin
    Failed := C_Return /= 0;
  end Activate;

  --
  -- Get_Ports
  --

  procedure Get_Ports_Free (Data : System.Address);
  pragma Import (C, Get_Ports_Free, "jack_ada_client_get_ports_free");

  procedure Get_Ports
    (Client            : in     Client_t;
     Port_Name_Pattern : in     String;
     Port_Type_Pattern : in     String;
     Port_Flags        : in     Port_Flags_t;
     Ports             :    out Port_Name_Set_t)
  is
    Name    : Port_Name_t;
    Size    : Natural;
    C_Flags : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name  : aliased C.char_array       := C.To_C (Port_Name_Pattern);
    C_Type  : aliased C.char_array       := C.To_C (Port_Type_Pattern);
    Address : constant C_String.Arrays.Pointer_Array_t :=
      Thin.Get_Ports
        (Client            => System.Address (Client),
         Port_Name_Pattern => C_String.To_C_String (C_Name'Unchecked_Access),
         Type_Name_Pattern => C_String.To_C_String (C_Type'Unchecked_Access),
         Flags             => C_Flags);
  begin
    Size := C_String.Arrays.Size_Terminated (Address);

    for Index in 0 .. Size loop
      Port_Names.Set_Bounded_String
        (Source => C_String.Arrays.Index_Terminated (Address, Index),
         Target => Name);
      Port_Name_Sets.Insert (Ports, Name);
    end loop;

    -- The strings returned by jack_get_ports are heap allocated.
    Get_Ports_Free (System.Address (Address));
  end Get_Ports;

  --
  -- Status, option and flag mapping.
  --

  type Status_Map_t is array (Status_Selector_t) of Thin.Status_t;

  Status_Map : constant Status_Map_t := Status_Map_t'
    (Failure               => Thin.JackFailure,
     Invalid_Option        => Thin.JackInvalidOption,
     Name_Not_Unique       => Thin.JackNameNotUnique,
     Server_Started        => Thin.JackServerStarted,
     Server_Failed         => Thin.JackServerFailed,
     Server_Error          => Thin.JackServerError,
     No_Such_Client        => Thin.JackNoSuchClient,
     Load_Failure          => Thin.JackLoadFailure,
     Init_Failure          => Thin.JackInitFailure,
     Shared_Memory_Failure => Thin.JackShmFailure,
     Version_Error         => Thin.JackVersionError);

  type Options_Map_t is array (Option_Selector_t) of Thin.Options_t;

  Options_Map : constant Options_Map_t := Options_Map_t'
    (Do_Not_Start_Server => Thin.JackNoStartServer,
     Use_Exact_Name      => Thin.JackUseExactName,
     Server_Name         => Thin.JackServerName,
     Load_Name           => Thin.JackLoadName,
     Load_Initialize     => Thin.JackLoadInit);

  type Port_Flags_Map_t is array (Port_Flag_Selector_t) of Thin.Port_Flags_t;

  Port_Flags_Map : constant Port_Flags_Map_t := Port_Flags_Map_t'
    (Port_Is_Input    => Thin.JackPortIsInput,
     Port_Is_Output   => Thin.JackPortIsOutput,
     Port_Is_Physical => Thin.JackPortIsPhysical,
     Port_Can_Monitor => Thin.JackPortCanMonitor,
     Port_Is_Terminal => Thin.JackPortIsTerminal);

  function Map_Options_To_Thin (Options : Options_t) return Thin.Options_t is
    Return_Options : Thin.Options_t := 0;
  begin
    for Selector in Options_t'Range loop
      if Options (Selector) then
        Return_Options := Return_Options or Options_Map (Selector);
      end if;
    end loop;
    return Return_Options;
  end Map_Options_To_Thin;

  function Map_Port_Flags_To_Thin (Port_Flags : Port_Flags_t) return Thin.Port_Flags_t is
    Return_Port_Flags : Thin.Port_Flags_t := 0;
  begin
    for Selector in Port_Flags_t'Range loop
      if Port_Flags (Selector) then
        Return_Port_Flags := Return_Port_Flags or Port_Flags_Map (Selector);
      end if;
    end loop;
    return Return_Port_Flags;
  end Map_Port_Flags_To_Thin;

  function Map_Status_To_Thin (Status : Status_t) return Thin.Status_t is
    Return_Status : Thin.Status_t := 0;
  begin
    for Selector in Status_t'Range loop
      if Status (Selector) then
        Return_Status := Return_Status or Status_Map (Selector);
      end if;
    end loop;
    return Return_Status;
  end Map_Status_To_Thin;

  function Map_Thin_To_Options (Options : Thin.Options_t) return Options_t is
    Return_Options : Options_t := (others => False);
  begin
    for Selector in Options_t'Range loop
      Return_Options (Selector) :=
        (Options and Options_Map (Selector)) = Options_Map (Selector);
    end loop;
    return Return_Options;
  end Map_Thin_To_Options;

  function Map_Thin_To_Port_Flags (Port_Flags : Thin.Port_Flags_t) return Port_Flags_t is
    Return_Port_Flags : Port_Flags_t := (others => False);
  begin
    for Selector in Port_Flags_t'Range loop
      Return_Port_Flags (Selector) :=
        (Port_Flags and Port_Flags_Map (Selector)) = Port_Flags_Map (Selector);
    end loop;
    return Return_Port_Flags;
  end Map_Thin_To_Port_Flags;

  function Map_Thin_To_Status (Status : Thin.Status_t) return Status_t is
    Return_Status : Status_t := (others => False);
  begin
    for Selector in Status_t'Range loop
      Return_Status (Selector) :=
        (Status and Status_Map (Selector)) = Status_Map (Selector);
    end loop;
    return Return_Status;
  end Map_Thin_To_Status;

  --
  -- Open
  --

  procedure Open
    (Client_Name : in     String;
     Options     : in     Options_t;
     Client      :    out Client_t;
     Status      : in out Status_t)
  is
    C_Options : constant Thin.Options_t := Map_Options_To_Thin (Options);
    C_Name    : aliased C.char_array   := C.To_C (Client_Name);
    C_Status  : aliased Thin.Status_t;
    C_Client  : System.Address;
  begin
    C_Client := Thin.Client_Open
      (Client_Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Options     => C_Options,
       Status      => C_Status'Address);
    Status := Map_Thin_To_Status (C_Status);

    if C_Client = System.Null_Address then
      Client := Invalid_Client;
    else
      Client := Client_t (C_Client);
    end if;
  end Open;

  --
  -- Port_Name_Size
  --

  function Port_Name_Size return Natural is
  begin
    return Natural (Thin.Port_Name_Size);
  end Port_Name_Size;

  --
  -- Port_Register
  --

  procedure Port_Register
    (Client      : in     Client_t;
     Port        :    out Port_t;
     Port_Name   : in     Port_Name_t;
     Port_Type   : in     String;
     Port_Flags  : in     Port_Flags_t;
     Buffer_Size : in     Natural := 0)
  is
    C_Flags : constant Thin.Port_Flags_t := Map_Port_Flags_To_Thin (Port_Flags);
    C_Name  : aliased C.char_array       := C.To_C (Port_Names.To_String (Port_Name));
    C_Port  : System.Address;
    C_Type  : aliased C.char_array       := C.To_C (Port_Type);
  begin
    C_Port := Thin.Port_Register
      (Client      => System.Address (Client),
       Port_Name   => C_String.To_C_String (C_Name'Unchecked_Access),
       Port_Type   => C_String.To_C_String (C_Type'Unchecked_Access),
       Flags       => C_Flags,
       Buffer_Size => C.unsigned_long (Buffer_Size));

    if C_Port = System.Null_Address then
      Port := Invalid_Port;
    else
      Port := Port_t (C_Port);
    end if;
  end Port_Register;

end Jack.Client;

Use type declarations

Use type declarations


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

with Orka.SIMD;

generic
   type Element_Type is digits <>;
   type Vector_Type is array (SIMD.Index_Homogeneous) of Element_Type;
   type Matrix_Type is array (SIMD.Index_Homogeneous) of Vector_Type;
   with function Multiply_Matrices (Left, Right : Matrix_Type) return Matrix_Type;
   with function "-" (Elements : Vector_Type) return Vector_Type;
   with function Transpose_Matrix (Matrix : Matrix_Type) return Matrix_Type;
package Orka.Transforms.SIMD_Matrices is
   pragma Preelaborate;

   subtype Matrix4 is Matrix_Type;

   subtype Vector4 is Vector_Type;

   function Identity_Value return Matrix_Type is
     (((1.0, 0.0, 0.0, 0.0),
       (0.0, 1.0, 0.0, 0.0),
       (0.0, 0.0, 1.0, 0.0),
       (0.0, 0.0, 0.0, 1.0)));

   function T (Offset : Vector_Type) return Matrix_Type;

   function Rx (Angle : Element_Type) return Matrix_Type;
   function Ry (Angle : Element_Type) return Matrix_Type;
   function Rz (Angle : Element_Type) return Matrix_Type;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type;

   function S (Factors : Vector_Type) return Matrix_Type;

   function "*" (Left, Right : Matrix_Type) return Matrix_Type renames Multiply_Matrices;

   function "+" (Offset : Vector_Type; Matrix : Matrix_Type) return Matrix_Type;
   --  Add a translation transformation to the matrix

   function "*" (Factor : Element_Type; Matrix : Matrix_Type) return Matrix_Type;
   --  Add a scale transformation to the matrix

   procedure Rotate_At_Origin (Matrix : in out Matrix_Type; Axis : Vector_Type; Angle : Element_Type);
   --  Add a rotation transformation to the matrix with the center
   --  of rotation at the origin to the matrix

   procedure Rotate (Matrix : in out Matrix_Type; Axis : Vector_Type;
                     Angle  : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation to the matrix with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_X_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the X axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_Y_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the Y axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_Z_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the Z axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_X (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the X axis with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_Y (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the Y axis with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_Z (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the Z axis with the center
   --  of rotation at the given point to the matrix

   --  procedure Rotate_Quaternion (Matrix : in out Matrix_Type; Quaternion : ?);
   --  procedure Rotate_Euler (Matrix : in out Matrix_Type; Euler : ?);

   procedure Translate (Matrix : in out Matrix_Type; Offset : Vector_Type);
   --  Add a translation transformation to the matrix

   procedure Scale (Matrix : in out Matrix_Type; Factors : Vector_Type);
   procedure Scale (Matrix : in out Matrix_Type; Factor : Element_Type);

   procedure Transpose (Matrix : in out Matrix_Type);
   --  Transpose the matrix

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type;

end Orka.Transforms.SIMD_Matrices;

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

with Orka.SIMD;

generic
   type Element_Type is digits <>;
   type Vector_Type is array (SIMD.Index_Homogeneous) of Element_Type;
   type Matrix_Type is array (SIMD.Index_Homogeneous) of Vector_Type;
   with function Multiply_Matrices (Left, Right : Matrix_Type) return Matrix_Type;
   with function "-" (Elements : Vector_Type) return Vector_Type;
   with function Transpose_Matrix (Matrix : Matrix_Type) return Matrix_Type;
package Orka.Transforms.SIMD_Matrices is
   pragma Preelaborate;

   subtype Matrix4 is Matrix_Type;

   subtype Vector4 is Vector_Type;

   function Identity_Value return Matrix_Type is
     (((1.0, 0.0, 0.0, 0.0),
       (0.0, 1.0, 0.0, 0.0),
       (0.0, 0.0, 1.0, 0.0),
       (0.0, 0.0, 0.0, 1.0)));

   function T (Offset : Vector_Type) return Matrix_Type;

   function Rx (Angle : Element_Type) return Matrix_Type;
   function Ry (Angle : Element_Type) return Matrix_Type;
   function Rz (Angle : Element_Type) return Matrix_Type;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type;

   function S (Factors : Vector_Type) return Matrix_Type;

   function "*" (Left, Right : Matrix_Type) return Matrix_Type renames Multiply_Matrices;

   function "+" (Offset : Vector_Type; Matrix : Matrix_Type) return Matrix_Type;
   --  Add a translation transformation to the matrix

   function "*" (Factor : Element_Type; Matrix : Matrix_Type) return Matrix_Type;
   --  Add a scale transformation to the matrix

   procedure Rotate_At_Origin (Matrix : in out Matrix_Type; Axis : Vector_Type; Angle : Element_Type);
   --  Add a rotation transformation to the matrix with the center
   --  of rotation at the origin to the matrix

   procedure Rotate (Matrix : in out Matrix_Type; Axis : Vector_Type;
                     Angle  : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation to the matrix with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_X_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the X axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_Y_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the Y axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_Z_At_Origin (Matrix : in out Matrix_Type; Angle : Element_Type);
   --  Add a rotation transformation around the Z axis with the center
   --  of rotation at the origin to the matrix

   procedure Rotate_X (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the X axis with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_Y (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the Y axis with the center
   --  of rotation at the given point to the matrix

   procedure Rotate_Z (Matrix : in out Matrix_Type; Angle : Element_Type; Point : Vector_Type);
   --  Add a rotation transformation around the Z axis with the center
   --  of rotation at the given point to the matrix

   --  procedure Rotate_Quaternion (Matrix : in out Matrix_Type; Quaternion : ?);
   --  procedure Rotate_Euler (Matrix : in out Matrix_Type; Euler : ?);

   procedure Translate (Matrix : in out Matrix_Type; Offset : Vector_Type);
   --  Add a translation transformation to the matrix

   procedure Scale (Matrix : in out Matrix_Type; Factors : Vector_Type);
   procedure Scale (Matrix : in out Matrix_Type; Factor : Element_Type);

   procedure Transpose (Matrix : in out Matrix_Type);
   --  Transpose the matrix

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type
     with Pre => FOV > 0.0 and Aspect > 0.0 and Z_Near > 0.0 and Z_Far > Z_Near;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type
     with Pre => FOV > 0.0 and Aspect > 0.0 and Z_Near > 0.0;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type
     with Pre => Z_Near >= 0.0 and Z_Far >= 0.0;

end Orka.Transforms.SIMD_Matrices;

orka: Add pre conditions to projection functions

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


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

with Util.Beans.Objects;

--  The ASF.Validators.Texts defines various text oriented validators.
package body ASF.Validators.Texts is

   --  ------------------------------
   --  Length_Validator
   --  ------------------------------

   --  ------------------------------
   --  Create a length validator.
   --  ------------------------------
   function Create_Length_Validator (Minimum : in Natural;
                                     Maximum : in Natural) return Validator_Access is
      Result : constant Length_Validator_Access := new Length_Validator;
   begin
      Result.Minimum := Minimum;
      Result.Maximum := Maximum;
      return Result.all'Access;
   end Create_Length_Validator;

   --  ------------------------------
   --  Verify that the value's length is between the validator minimum and maximum
   --  boundaries.
   --  If some error are found, the procedure should create a FacesMessage
   --  describing the problem and add that message to the current faces context.
   --  The procedure can examine the state and modify the component tree.
   --  It must raise the Invalid_Value exception if the value is not valid.
   --  ------------------------------
   procedure Validate (Valid     : in Length_Validator;
                       Context   : in out ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in out ASF.Components.Base.UIComponent'Class;
                       Value     : in EL.Objects.Object) is
   begin
      if EL.Objects.Is_Null (Value) then
         return;
      end if;

      declare
         S : constant String := EL.Objects.To_String (Value);
      begin
         if S'Length > Valid.Maximum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MAXIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Maximum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
         if S'Length < Valid.Minimum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MINIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Minimum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
      end;
   end Validate;

end ASF.Validators.Texts;

-----------------------------------------------------------------------
--  asf-validators-texts -- ASF Texts Validators
--  Copyright (C) 2011, 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.Beans.Objects;

--  The ASF.Validators.Texts defines various text oriented validators.
package body ASF.Validators.Texts is

   --  ------------------------------
   --  Length_Validator
   --  ------------------------------

   --  ------------------------------
   --  Create a length validator.
   --  ------------------------------
   function Create_Length_Validator (Minimum : in Natural;
                                     Maximum : in Natural) return Validator_Access is
      Result : constant Length_Validator_Access := new Length_Validator;
   begin
      Result.Minimum := Minimum;
      Result.Maximum := Maximum;
      return Result.all'Access;
   end Create_Length_Validator;

   --  ------------------------------
   --  Verify that the value's length is between the validator minimum and maximum
   --  boundaries.
   --  If some error are found, the procedure should create a FacesMessage
   --  describing the problem and add that message to the current faces context.
   --  The procedure can examine the state and modify the component tree.
   --  It must raise the Invalid_Value exception if the value is not valid.
   --  ------------------------------
   procedure Validate (Valid     : in Length_Validator;
                       Context   : in out ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in out ASF.Components.Base.UIComponent'Class;
                       Value     : in EL.Objects.Object) is
   begin
      if EL.Objects.Is_Null (Value) then
         return;
      end if;

      declare
         S : constant String := EL.Objects.To_String (Value);
      begin
         if S'Length > Valid.Maximum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MAXIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Maximum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
         if S'Length < Valid.Minimum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MINIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Minimum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
      end;
   end Validate;

   --  ------------------------------
   --  Regex_Validator
   --  ------------------------------

   --  ------------------------------
   --  Create a regex validator.
   --  ------------------------------
   function Create_Regex_Validator (Pattern : in GNAT.Regpat.Pattern_Matcher)
                                   return Validator_Access is
      Result : constant Regex_Validator_Access := new Regex_Validator (Pattern.Size);
   begin
      Result.Pattern := Pattern;
      return Result.all'Access;
   end Create_Regex_Validator;

   --  ------------------------------
   --  Verify that the value's length is between the validator minimum and maximum
   --  boundaries.
   --  If some error are found, the procedure should create a FacesMessage
   --  describing the problem and add that message to the current faces context.
   --  The procedure can examine the state and modify the component tree.
   --  It must raise the Invalid_Value exception if the value is not valid.
   --  ------------------------------
   procedure Validate (Valid     : in Regex_Validator;
                       Context   : in out ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in out ASF.Components.Base.UIComponent'Class;
                       Value     : in EL.Objects.Object) is
   begin
      if EL.Objects.Is_Null (Value) then
         return;
      end if;

      declare
         S : constant String := EL.Objects.To_String (Value);
      begin
         if not GNAT.Regpat.Match (Valid.Pattern, S) then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => REGEX_MESSAGE_ID,
                                   Arg1    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
      end;
   end Validate;

end ASF.Validators.Texts;

Implement the Regex_Validator operation for the <f:validateRegex> JSF tag


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

package body Gen.Model.Operations is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Operation_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "parameters" or Name = "columns" then
         return From.Parameters_Bean;

      elsif Name = "return" then
         return Util.Beans.Objects.To_Object (From.Return_Type);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Operation_Definition) is
   begin
      null;
   end Prepare;

   --  ------------------------------
   --  Initialize the operation definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Operation_Definition) is
   begin
      O.Parameters_Bean := Util.Beans.Objects.To_Object (O.Parameters'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);

   end Initialize;

   --  ------------------------------
   --  Add an operation parameter with the given name and type.
   --  ------------------------------
   procedure Add_Parameter (Into      : in out Operation_Definition;
                            Name      : in Unbounded_String;
                            Of_Type   : in Unbounded_String;
                            Parameter : out Parameter_Definition_Access) is
   begin
      Parameter := new Parameter_Definition;
      Parameter.Name := Name;
      Parameter.Type_Name := Of_Type;
      Into.Parameters.Append (Parameter);
   end Add_Parameter;

   --  ------------------------------
   --  Create an operation with the given name.
   --  ------------------------------
   function Create_Operation (Name : in Unbounded_String) return Operation_Definition_Access is
      Result : constant Operation_Definition_Access := new Operation_Definition;
   begin
      return Result;
   end Create_Operation;

end Gen.Model.Operations;

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

package body Gen.Model.Operations is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Operation_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "parameters" or Name = "columns" then
         return From.Parameters_Bean;

      elsif Name = "return" then
         return Util.Beans.Objects.To_Object (From.Return_Type);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  Prepare the generation of the model.
   overriding
   procedure Prepare (O : in out Operation_Definition) is
   begin
      null;
   end Prepare;

   --  ------------------------------
   --  Initialize the operation definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Operation_Definition) is
   begin
      O.Parameters_Bean := Util.Beans.Objects.To_Object (O.Parameters'Unchecked_Access,
                                                         Util.Beans.Objects.STATIC);

   end Initialize;

   --  ------------------------------
   --  Add an operation parameter with the given name and type.
   --  ------------------------------
   procedure Add_Parameter (Into      : in out Operation_Definition;
                            Name      : in Unbounded_String;
                            Of_Type   : in Unbounded_String;
                            Parameter : out Parameter_Definition_Access) is
   begin
      Parameter := new Parameter_Definition;
      Parameter.Name := Name;
      Parameter.Type_Name := Of_Type;
      Into.Parameters.Append (Parameter);
   end Add_Parameter;

   --  ------------------------------
   --  Create an operation with the given name.
   --  ------------------------------
   function Create_Operation (Name : in Unbounded_String) return Operation_Definition_Access is
      pragma Unreferenced (Name);

      Result : constant Operation_Definition_Access := new Operation_Definition;
   begin
      return Result;
   end Create_Operation;

end Gen.Model.Operations;

Fix compilation warning

Fix compilation warning


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

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions");

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("There is no security context, permission denied");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused");
         raise NO_PERMISSION;
      end if;
   end Check;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      SQL     : Util.Beans.Objects.Object;
      Entity  : ADO.Entity_Type := 0;
      Count   : Natural := 0;
      Manager : Entity_Policy_Access;
      Session : ADO.Sessions.Session;
   end record;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Entity := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Entity = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len    => SQL'Length,
                                               SQL    => SQL,
                                               Entity => Into.Entity);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entity := 0;
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Entity_Policy) return String is
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
end AWA.Permissions;

-----------------------------------------------------------------------
--  awa-permissions -- Permissions module
--  Copyright (C) 2011, 2012, 2013 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.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions");

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("There is no security context, permission denied");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused");
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Objects.Object_Ref'Class) is
   begin
      if Entity.Is_Null then
         Log.Debug ("Permission is refused because the entity is null.");
         raise NO_PERMISSION;
      end if;
      Check (Permission, ADO.Objects.Get_Value (Entity.Get_Key));
   end Check;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      SQL     : Util.Beans.Objects.Object;
      Entity  : ADO.Entity_Type := 0;
      Count   : Natural := 0;
      Manager : Entity_Policy_Access;
      Session : ADO.Sessions.Session;
   end record;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Entity := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Entity = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len    => SQL'Length,
                                               SQL    => SQL,
                                               Entity => Into.Entity);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entity := 0;
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Entity_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
end AWA.Permissions;

Implement the Check procedure, if the database object is null, refuse the permission


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

with Util.Tests;
package Util.Processes.Tests is

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

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

   --  Tests when the process is not launched
   procedure Test_No_Process (T : in out Test);

   --  Test executing a process
   procedure Test_Spawn (T : in out Test);

   --  Test output pipe redirection: read the process standard output
   procedure Test_Output_Pipe (T : in out Test);

   --  Test input pipe redirection: write the process standard input
   procedure Test_Input_Pipe (T : in out Test);

   --  Test shell splitting.
   procedure Test_Shell_Splitting_Pipe (T : in out Test);

   --  Test launching several processes through pipes in several threads.
   procedure Test_Multi_Spawn (T : in out Test);

   --  Test output file redirection.
   procedure Test_Output_Redirect (T : in out Test);

   --  Test input file redirection.
   procedure Test_Input_Redirect (T : in out Test);

   --  Test the Tools.Execute operation.
   procedure Test_Tools_Execute (T : in out Test);

end Util.Processes.Tests;

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

with Util.Tests;
package Util.Processes.Tests is

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

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

   --  Tests when the process is not launched
   procedure Test_No_Process (T : in out Test);

   --  Test executing a process
   procedure Test_Spawn (T : in out Test);

   --  Test output pipe redirection: read the process standard output
   procedure Test_Output_Pipe (T : in out Test);

   --  Test input pipe redirection: write the process standard input
   procedure Test_Input_Pipe (T : in out Test);

   --  Test shell splitting.
   procedure Test_Shell_Splitting_Pipe (T : in out Test);

   --  Test launching several processes through pipes in several threads.
   procedure Test_Multi_Spawn (T : in out Test);

   --  Test output file redirection.
   procedure Test_Output_Redirect (T : in out Test);

   --  Test input file redirection.
   procedure Test_Input_Redirect (T : in out Test);

   --  Test chaning working directory.
   procedure Test_Set_Working_Directory (T : in out Test);

   --  Test the Tools.Execute operation.
   procedure Test_Tools_Execute (T : in out Test);

end Util.Processes.Tests;

Declare the Test_Set_Working_Directory procedure