-----------------------------------------------------------------------
--  util-encoders-lzma -- LZMA compression and decompression
--  Copyright (C) 2018 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 Lzma.Check;
with Lzma.Container;
with Interfaces.C;

package body Util.Encoders.Lzma is

   use type Interfaces.C.size_t;
   use type Ada.Streams.Stream_Element_Offset;
   use type Base.lzma_ret;

   subtype Offset is Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Compress the binary input stream represented by Data by using
   --  the LZMA compression into the output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Compress;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      Action : Base.lzma_action := Base.LZMA_RUN;
      Result : Base.lzma_ret;
      Pos    : Ada.Streams.Stream_Element_Offset := Data'First;
   begin
      E.Stream.next_out := Into (Into'First)'Unchecked_Access;
      E.Stream.avail_out := Into'Length;
      E.Stream.next_in := Data (Pos)'Unrestricted_Access;
      E.Stream.avail_in := Interfaces.C.size_t (Data'Length);
      loop
         Result := Base.lzma_code (E.Stream'Unchecked_Access, Action);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if E.Stream.avail_out = 0 or E.Stream.avail_in = 0 or Result = Base.LZMA_STREAM_END then
            Last := Into'First + Into'Length - Offset (E.Stream.avail_out) - 1;
            Encoded := Data'First + Data'Length - Offset (E.Stream.avail_in);
            return;
         end if;
         exit when Result /= Base.LZMA_OK;
      end loop;
   end Transform;

   --  ------------------------------
   --  Finish compression of the input array.
   --  ------------------------------
   overriding
   procedure Finish (E    : in out Compress;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset) is
      Result : Base.lzma_ret;
   begin
      E.Stream.next_out := Into (Into'First)'Unchecked_Access;
      E.Stream.avail_out := Into'Length;
      E.Stream.next_in := null;
      E.Stream.avail_in := 0;
      Result := Base.lzma_code (E.Stream'Unchecked_Access, Base.LZMA_FINISH);
      Last := Into'First + Into'Length - Offset (E.Stream.avail_out) - 1;
   end Finish;

   overriding
   procedure Initialize (E : in out Compress) is
      Result : Base.lzma_ret;
   begin
      Result := Container.lzma_easy_encoder (E.Stream'Unchecked_Access, 6,
                                             Check.LZMA_CHECK_CRC64);
   end Initialize;

   overriding
   procedure Finalize (E : in out Compress) is
   begin
      Base.lzma_end (E.Stream'Unchecked_Access);
   end Finalize;

end Util.Encoders.Lzma;

-----------------------------------------------------------------------
--  util-encoders-lzma -- LZMA compression and decompression
--  Copyright (C) 2018 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 Lzma.Check;
with Lzma.Container;
with Interfaces.C;

package body Util.Encoders.Lzma is

   use type Interfaces.C.size_t;
   use type Ada.Streams.Stream_Element_Offset;
   use type Base.lzma_ret;

   subtype Offset is Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Compress the binary input stream represented by Data by using
   --  the LZMA compression into the output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Compress;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
      Result : Base.lzma_ret;
   begin
      E.Stream.next_out := Into (Into'First)'Unchecked_Access;
      E.Stream.avail_out := Into'Length;
      E.Stream.next_in := Data (Data'First)'Unrestricted_Access;
      E.Stream.avail_in := Interfaces.C.size_t (Data'Length);
      loop
         Result := Base.lzma_code (E.Stream'Unchecked_Access, Base.LZMA_RUN);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if E.Stream.avail_out = 0 or E.Stream.avail_in = 0 or Result = Base.LZMA_STREAM_END then
            Last := Into'First + Into'Length - Offset (E.Stream.avail_out) - 1;
            Encoded := Data'First + Data'Length - Offset (E.Stream.avail_in);
            return;
         end if;
         exit when Result /= Base.LZMA_OK;
      end loop;
   end Transform;

   --  ------------------------------
   --  Finish compression of the input array.
   --  ------------------------------
   overriding
   procedure Finish (E    : in out Compress;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset) is
      Result : Base.lzma_ret;
      pragma Unreferenced (Result);
   begin
      E.Stream.next_out := Into (Into'First)'Unchecked_Access;
      E.Stream.avail_out := Into'Length;
      E.Stream.next_in := null;
      E.Stream.avail_in := 0;
      Result := Base.lzma_code (E.Stream'Unchecked_Access, Base.LZMA_FINISH);
      Last := Into'First + Into'Length - Offset (E.Stream.avail_out) - 1;
   end Finish;

   overriding
   procedure Initialize (E : in out Compress) is
      Result : Base.lzma_ret;
      pragma Unreferenced (Result);
   begin
      Result := Container.lzma_easy_encoder (E.Stream'Unchecked_Access, 6,
                                             Check.LZMA_CHECK_CRC64);
   end Initialize;

   overriding
   procedure Finalize (E : in out Compress) is
   begin
      Base.lzma_end (E.Stream'Unchecked_Access);
   end Finalize;

end Util.Encoders.Lzma;

Fix compilation warning

Fix compilation warning


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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
package Security.Policies.Roles is

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Rename Set_Reader_Config into Prepare_Config


with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar; use Ada.Calendar;
with Ada.Numerics.Big_Numbers.Big_Integers;
use Ada.Numerics.Big_Numbers.Big_Integers;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

with Fibonacci;
with Perfect_Number;
with Primes;

procedure Main is
   package Fib renames Fibonacci;
   package Pn renames Perfect_Number;

   procedure Put_Elapsed (Tic : Time; Toc : Time := Clock) is
   begin
      Put_Line (" elapsed time: " & Duration'Image(Toc - Tic) & "s");
   end Put_Elapsed;

   -- overload Img function for string representatin of result data
   function Img (X : Natural) return String renames Natural'Image;

   function Img (X : Big_Natural) return String renames Fib.Big_Natural_Image;

   function Img (X : Pn.Pn_Vectors.Vector) return String is
      Res : Unbounded_String := Null_Unbounded_String;
   begin
      Res := Res & "[";
      for E of X loop
         Res := Res & Img (E) & ",";
      end loop;
      Res := Res & "]";
      return To_String (Res);
   end Img;

   function Img (X : Primes.Prime_Vectors.Vector) return String is
      Res : Unbounded_String := Null_Unbounded_String;
   begin
      Res := Res & "[";
      for E of X loop
         Res := Res & Img (E) & ",";
      end loop;
      Res := Res & "]";
      return To_String (Res);
   end Img;

   Tic : Time;
begin
   Put_Line ("Benchmark");
   Put_Line ("=========");
   New_Line;

   Put_Line ("Fibonacci Numbers");
   Put_Line ("-----------------");
   Tic := Clock;
   Put ("Fib_Naive (35)   = " & Img (Fib.Fib_Naive (35)));
   Put_Elapsed (Tic);
   Tic := Clock;
   Put ("Fib_Iter (1000)  = " & Img (Fib.Fib_Iter (1000)));
   Put_Elapsed (Tic);
   Tic := Clock;
   Put ("Fib_Recur (1000) = " & Img (Fib.Fib_Recur (1000)));
   Put_Elapsed (Tic);
   New_Line;

   Put_Line ("Perfect Numbers");
   Put_Line ("---------------");
   Tic := Clock;
   Put ("Perfect_Numbers (10000) = " & Img (Pn.Get_Perfect_Numbers (10000)));
   Put_Elapsed (Tic);
   New_line;

   Put_Line ("Prime Numbers");
   Put_Line ("-------------");
   Tic := Clock;
   Put ("Get_Primes (10000): (" & Img (Primes.Get_Primes (10_000)) & ")");
   Put_Elapsed (Tic);
   Tic := Clock;
   -- FIXME: Provide Img overload for Primes.Prime_Vectors_Big.Vector
   --Put ("Get_Primes (10000): (" & Img (Primes.Get_Primes (To_Big_Integer (10_000))) & ")");
   Put_Elapsed (Tic);
   New_Line;

end Main;

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar; use Ada.Calendar;
with Ada.Numerics.Big_Numbers.Big_Integers;
use Ada.Numerics.Big_Numbers.Big_Integers;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

with Fibonacci;
with Perfect_Number;
with Primes;

procedure Main is
   package Fib renames Fibonacci;
   package Pn renames Perfect_Number;

   procedure Put_Elapsed (Tic : Time; Toc : Time := Clock) is
   begin
      Put_Line (" elapsed time: " & Duration'Image(Toc - Tic) & "s");
   end Put_Elapsed;

   -- overload Img function for string representatin of result data
   function Img (X : Natural) return String renames Natural'Image;

   function Img (X : Big_Natural) return String renames Fib.Big_Natural_Image;

   function Img (X : Pn.Pn_Vectors.Vector) return String is
      Res : Unbounded_String := Null_Unbounded_String;
   begin
      Res := Res & "[";
      for E of X loop
         Res := Res & Img (E) & ",";
      end loop;
      Res := Res & "]";
      return To_String (Res);
   end Img;

   function Img (X : Primes.Prime_Vectors.Vector) return String is
      Res : Unbounded_String := Null_Unbounded_String;
   begin
      Res := Res & "[";
      for E of X loop
         Res := Res & Img (E) & ",";
      end loop;
      Res := Res & "]";
      return To_String (Res);
   end Img;

   function Img (X : Primes.Big_Prime_Vectors.Vector) return String is
      Res : Unbounded_String := Null_Unbounded_String;
   begin
      Res := Res & "[";
      for E of X loop
         Res := Res & Img (E) & ",";
      end loop;
      Res := Res & "]";
      return To_String (Res);
   end Img;

   Tic : Time;
begin
   Put_Line ("Benchmark");
   Put_Line ("=========");
   New_Line;

   Put_Line ("Fibonacci Numbers");
   Put_Line ("-----------------");
   Tic := Clock;
   Put ("Fib_Naive (35)   = " & Img (Fib.Fib_Naive (35)));
   Put_Elapsed (Tic);
   Tic := Clock;
   Put ("Fib_Iter (1000)  = " & Img (Fib.Fib_Iter (1000)));
   Put_Elapsed (Tic);
   Tic := Clock;
   Put ("Fib_Recur (1000) = " & Img (Fib.Fib_Recur (1000)));
   Put_Elapsed (Tic);
   New_Line;

   Put_Line ("Perfect Numbers");
   Put_Line ("---------------");
   Tic := Clock;
   Put ("Perfect_Numbers (10000) = " & Img (Pn.Get_Perfect_Numbers (10000)));
   Put_Elapsed (Tic);
   New_line;

   Put_Line ("Prime Numbers");
   Put_Line ("-------------");
   Tic := Clock;
   Put ("Get_Primes (10000): (" & Img (Primes.Get_Primes (10_000)) & ")");
   Put_Elapsed (Tic);
   Tic := Clock;
   Put ("Get_Primes (10000): (" & Img (Primes.Get_Primes (To_Big_Integer (10_000))) & ")");
   Put_Elapsed (Tic);
   New_Line;

end Main;

add missing overload for Img ()

add missing overload for Img ()


-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  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 EL.Expressions;
with EL.Objects;
with EL.Contexts;
with EL.Contexts.Default;
with EL.Expressions.Tests;
with EL.Beans.Tests;
with EL.Contexts.Tests;
with EL.Utils.Tests;
package body EL.Testsuite is

   use EL.Objects;

   --  ------------------------------
   --  Test object integer
   --  ------------------------------
   procedure Test_To_Object_Integer (T : in out Test) is
   begin
      declare
         Value : constant EL.Objects.Object := To_Object (Integer (1));
      begin
         T.Assert (Condition => To_Integer (Value) = 1,
                   Message => "Object.To_Integer: invalid integer returned");
         T.Assert (Condition => To_Long_Integer (Value) = 1,
                   Message => "Object.To_Long_Integer: invalid integer returned");
         T.Assert (Condition => To_Boolean (Value),
                   Message => "Object.To_Boolean: invalid return");

         declare
            V2 : constant EL.Objects.Object := Value + To_Object (Long_Integer (100));
         begin
            T.Assert (Condition => To_Integer (V2) = 101,
                      Message => "To_Integer invalid after an add");
         end;
      end;
   end Test_To_Object_Integer;

   --  ------------------------------
   --  Test object integer
   --  ------------------------------
   procedure Test_Expression (T : in out Test) is
      E     : EL.Expressions.Expression;
      Value : Object;
      Ctx   : EL.Contexts.Default.Default_Context;
   begin
      --  Positive number
      E := EL.Expressions.Create_Expression ("12345678901", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Long_Long_Integer (Value) = Long_Long_Integer (12345678901),
                Message => "[1] Expression result invalid: " & To_String (Value));

      --  Negative number
      E := EL.Expressions.Create_Expression ("-10", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = -10,
                Message => "[2] Expression result invalid: " & To_String (Value));

      --  Simple add
      E := EL.Expressions.Create_Expression ("#{1+1}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 2,
                Message => "[2.1] Expression result invalid: " & To_String (Value));

      --  Constant expressions
      E := EL.Expressions.Create_Expression ("#{12 + (123 - 3) * 4}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 492,
                Message => "[3] Expression result invalid: " & To_String (Value));

      --  Constant expressions
      E := EL.Expressions.Create_Expression ("#{12 + (123 - 3) * 4 + (23? 10 : 0)}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 502,
                Message => "[4] Expression result invalid: " & To_String (Value));

      --  Choice expressions
      E := EL.Expressions.Create_Expression ("#{1 > 2 ? 12 + 2 : 3 * 3}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 9,
                Message => "[5] Expression result invalid: " & To_String (Value));

      --  Choice expressions using strings
      E := EL.Expressions.Create_Expression ("#{1 > 2 ? 12 + 2 : 'A string'}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_String (Value) = "A string",
                Message => "[6] Expression result invalid: " & To_String (Value));

   end Test_Expression;

   package Caller is new Util.Test_Caller (Test);

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Caller.Add_Test (Ret, "Test To_Object (Integer)",
                       Test_To_Object_Integer'Access);
      Caller.Add_Test (Ret, "Test Expressions", Test_Expression'Access);
      EL.Expressions.Tests.Add_Tests (Ret);
      EL.Contexts.Tests.Add_Tests (Ret);
      EL.Beans.Tests.Add_Tests (Ret);
      EL.Utils.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end EL.Testsuite;

-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  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 EL.Expressions;
with EL.Objects;
with EL.Contexts;
with EL.Contexts.Default;
with EL.Expressions.Tests;
with EL.Beans.Tests;
with EL.Contexts.Tests;
with EL.Utils.Tests;
package body EL.Testsuite is

   use EL.Objects;

   --  ------------------------------
   --  Test object integer
   --  ------------------------------
   procedure Test_To_Object_Integer (T : in out Test) is
   begin
      declare
         Value : constant EL.Objects.Object := To_Object (Integer (1));
      begin
         T.Assert (Condition => To_Integer (Value) = 1,
                   Message => "Object.To_Integer: invalid integer returned");
         T.Assert (Condition => To_Long_Integer (Value) = 1,
                   Message => "Object.To_Long_Integer: invalid integer returned");
         T.Assert (Condition => To_Boolean (Value),
                   Message => "Object.To_Boolean: invalid return");

         declare
            V2 : constant EL.Objects.Object := Value + To_Object (Long_Integer (100));
         begin
            T.Assert (Condition => To_Integer (V2) = 101,
                      Message => "To_Integer invalid after an add");
         end;
      end;
   end Test_To_Object_Integer;

   --  ------------------------------
   --  Test object integer
   --  ------------------------------
   procedure Test_Expression (T : in out Test) is
      E     : EL.Expressions.Expression;
      Value : Object;
      Ctx   : EL.Contexts.Default.Default_Context;
   begin
      --  Positive number
      E := EL.Expressions.Create_Expression ("12345678901", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Long_Long_Integer (Value) = Long_Long_Integer (12345678901),
                Message => "[1] Expression result invalid: " & To_String (Value));

      --  Negative number
      E := EL.Expressions.Create_Expression ("-10", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = -10,
                Message => "[2] Expression result invalid: " & To_String (Value));

      --  Simple add
      E := EL.Expressions.Create_Expression ("#{1+1}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 2,
                Message => "[2.1] Expression result invalid: " & To_String (Value));

      --  Constant expressions
      E := EL.Expressions.Create_Expression ("#{12 + (123 - 3) * 4}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 492,
                Message => "[3] Expression result invalid: " & To_String (Value));

      --  Constant expressions
      E := EL.Expressions.Create_Expression ("#{12 + (123 - 3) * 4 + (23? 10 : 0)}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 502,
                Message => "[4] Expression result invalid: " & To_String (Value));

      --  Choice expressions
      E := EL.Expressions.Create_Expression ("#{1 > 2 ? 12 + 2 : 3 * 3}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_Integer (Value) = 9,
                Message => "[5] Expression result invalid: " & To_String (Value));

      --  Choice expressions using strings
      E := EL.Expressions.Create_Expression ("#{1 > 2 ? 12 + 2 : 'A string'}", Ctx);
      Value := E.Get_Value (Ctx);
      T.Assert (Condition => To_String (Value) = "A string",
                Message => "[6] Expression result invalid: " & To_String (Value));

   end Test_Expression;

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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Caller.Add_Test (Ret, "Test To_Object (Integer)",
                       Test_To_Object_Integer'Access);
      Caller.Add_Test (Ret, "Test Expressions", Test_Expression'Access);
      EL.Expressions.Tests.Add_Tests (Ret);
      EL.Contexts.Tests.Add_Tests (Ret);
      EL.Beans.Tests.Add_Tests (Ret);
      EL.Utils.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end EL.Testsuite;

Use the test name EL

Use the test name EL


-----------------------------------------------------------------------
--  util-commands-tests - Test for commands
--  Copyright (C) 2018 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 GNAT.Command_Line;
with Util.Test_Caller;
with Util.Commands.Parsers.GNAT_Parser;
with Util.Commands.Drivers;
package body Util.Commands.Tests is

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

   type Test_Context_Type is record
      Number  : Integer;
      Success : Boolean := False;
   end record;

   package Test_Command is new
     Util.Commands.Drivers (Context_Type => Test_Context_Type,
                            Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                            Driver_Name  => "test");

   type Test_Command_Type is new Test_Command.Command_Type with record
      Opt_Count : aliased Integer := 0;
      Opt_V     : aliased Boolean := False;
      Opt_N     : aliased Boolean := False;
      Expect_V  : Boolean := False;
      Expect_N  : Boolean := False;
      Expect_C  : Integer := 0;
      Expect_A  : Integer := 0;
      Expect_Help : Boolean := False;
   end record;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration);

   --  Write the help associated with the command.
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Execute",
                       Test_Execute'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Help",
                       Test_Help'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Usage",
                       Test_Usage'Access);
   end Add_Tests;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type) is
      pragma Unreferenced (Name);
   begin
      Context.Success := Command.Opt_Count = Command.Expect_C and
        Command.Opt_V = Command.Expect_V and
        Command.Opt_N = Command.Expect_N and
        Args.Get_Count = Command.Expect_A and
        not Command.Expect_Help;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration) is
   begin
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-c:",
                                       Long_Switch => "--count=",
                                       Help        => "Number option",
                                       Section     => "",
                                       Initial     => Integer (0),
                                       Default     => Integer (10),
                                       Output      => Command.Opt_Count'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-v",
                                       Long_Switch => "--verbose",
                                       Help        => "Verbose option",
                                       Section     => "",
                                       Output      => Command.Opt_V'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-n",
                                       Long_Switch => "--not",
                                       Help        => "Not option",
                                       Section     => "",
                                       Output      => Command.Opt_N'Access);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in Test_Command_Type;
                   Context   : in out Test_Context_Type) is

   begin
      Context.Success := Command.Expect_Help;
   end Help;

   --  ------------------------------
   --  Tests when the execution of commands.
   --  ------------------------------
   procedure Test_Execute (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := True;
         C1.Expect_N := True;
         C1.Expect_C := 4;
         C1.Expect_A := 2;
         Initialize (Args, "list --count=4 -v -n test titi");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := False;
         C1.Expect_N := True;
         C1.Expect_C := 8;
         C1.Expect_A := 3;
         Initialize (Args, "list -c 8 -n test titi last");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

   end Test_Execute;

   --  ------------------------------
   --  Test execution of help.
   --  ------------------------------
   procedure Test_Help (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C2.Expect_Help := True;
         Initialize (Args, "help print");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Help;

   --  ------------------------------
   --  Test usage operation.
   --  ------------------------------
   procedure Test_Usage (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      Args.Initialize (Line => "cmd list");
      D.Usage (Args);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Usage;

end Util.Commands.Tests;

-----------------------------------------------------------------------
--  util-commands-tests - Test for commands
--  Copyright (C) 2018 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 GNAT.Command_Line;
with Util.Test_Caller;
with Util.Commands.Parsers.GNAT_Parser;
with Util.Commands.Drivers;
package body Util.Commands.Tests is

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

   type Test_Context_Type is record
      Number  : Integer;
      Success : Boolean := False;
   end record;

   package Test_Command is new
     Util.Commands.Drivers (Context_Type => Test_Context_Type,
                            Config_Parser => Util.Commands.Parsers.GNAT_Parser.Config_Parser,
                            Driver_Name  => "test");

   type Test_Command_Type is new Test_Command.Command_Type with record
      Opt_Count : aliased Integer := 0;
      Opt_V     : aliased Boolean := False;
      Opt_N     : aliased Boolean := False;
      Expect_V  : Boolean := False;
      Expect_N  : Boolean := False;
      Expect_C  : Integer := 0;
      Expect_A  : Integer := 0;
      Expect_Help : Boolean := False;
   end record;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type);

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Test_Context_Type);

   --  Write the help associated with the command.
   procedure Help (Command   : in out Test_Command_Type;
                   Context   : in out Test_Context_Type);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Execute",
                       Test_Execute'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Help",
                       Test_Help'Access);
      Caller.Add_Test (Suite, "Test Util.Commands.Driver.Usage",
                       Test_Usage'Access);
   end Add_Tests;

   overriding
   procedure Execute (Command   : in out Test_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Test_Context_Type) is
      pragma Unreferenced (Name);
   begin
      Context.Success := Command.Opt_Count = Command.Expect_C and
        Command.Opt_V = Command.Expect_V and
        Command.Opt_N = Command.Expect_N and
        Args.Get_Count = Command.Expect_A and
        not Command.Expect_Help;
   end Execute;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Command : in out Test_Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Test_Context_Type) is
   begin
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-c:",
                                       Long_Switch => "--count=",
                                       Help        => "Number option",
                                       Section     => "",
                                       Initial     => Integer (0),
                                       Default     => Integer (10),
                                       Output      => Command.Opt_Count'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-v",
                                       Long_Switch => "--verbose",
                                       Help        => "Verbose option",
                                       Section     => "",
                                       Output      => Command.Opt_V'Access);
      GNAT.Command_Line.Define_Switch (Config      => Config,
                                       Switch      => "-n",
                                       Long_Switch => "--not",
                                       Help        => "Not option",
                                       Section     => "",
                                       Output      => Command.Opt_N'Access);
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Command   : in out Test_Command_Type;
                   Context   : in out Test_Context_Type) is

   begin
      Context.Success := Command.Expect_Help;
   end Help;

   --  ------------------------------
   --  Tests when the execution of commands.
   --  ------------------------------
   procedure Test_Execute (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := True;
         C1.Expect_N := True;
         C1.Expect_C := 4;
         C1.Expect_A := 2;
         Initialize (Args, "list --count=4 -v -n test titi");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_V := False;
         C1.Expect_N := True;
         C1.Expect_C := 8;
         C1.Expect_A := 3;
         Initialize (Args, "list -c 8 -n test titi last");
         D.Execute ("list", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

   end Test_Execute;

   --  ------------------------------
   --  Test execution of help.
   --  ------------------------------
   procedure Test_Help (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      declare
         Ctx   : Test_Context_Type;
      begin
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;

      declare
         Ctx   : Test_Context_Type;
      begin
         C2.Expect_Help := True;
         Initialize (Args, "help print");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Help;

   --  ------------------------------
   --  Test usage operation.
   --  ------------------------------
   procedure Test_Usage (T : in out Test) is
      C1    : aliased Test_Command_Type;
      C2    : aliased Test_Command_Type;
      H     : aliased Test_Command.Help_Command_Type;
      D     : Test_Command.Driver_Type;
      Args  : String_Argument_List (500, 30);
   begin
      D.Set_Description ("Test command");
      D.Add_Command ("list", C1'Unchecked_Access);
      D.Add_Command ("print", C2'Unchecked_Access);
      D.Add_Command ("help", H'Unchecked_Access);
      Args.Initialize (Line => "cmd list");
      declare
         Ctx   : Test_Context_Type;
      begin
         D.Usage (Args, Ctx);
         C1.Expect_Help := True;
         Initialize (Args, "help list");
         D.Execute ("help", Args, Ctx);
         T.Assert (Ctx.Success, "Some arguments not parsed correctly");
      end;
   end Test_Usage;

end Util.Commands.Tests;

Update the unit test

Update the unit test


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

with Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with Util.Properties;
with Util.Strings;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Ada.Finalization.Limited_Controlled with record
      Count : Natural := 0;
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is abstract;

   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is abstract;

   --  Create a delete statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is abstract;

   --  Create an insert statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is abstract;

   --  Create an update statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is abstract;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Database_Connection) is abstract;

   --  Commit the current transaction.
   procedure Commit (Database : in out Database_Connection) is abstract;

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Database_Connection) is abstract;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is abstract;

   --  Get the database driver which manages this connection.
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is abstract;

   --  Closes the database connection
   procedure Close (Database : in out Database_Connection) is abstract;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String);

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String;

   --  Get the server hostname.
   function Get_Server (Controller : in Configuration) return String;

   --  Get the server port.
   function Get_Port (Controller : in Configuration) return Integer;

   --  Get the database name.
   function Get_Database (Controller : in Configuration) return String;

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access);

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (D      : in out Driver;
                                Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is abstract;

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String := Null_Unbounded_String;
      Server     : Unbounded_String := Null_Unbounded_String;
      Port       : Integer := 0;
      Database   : Unbounded_String := Null_Unbounded_String;
      Properties : Util.Properties.Manager;
      Driver     : Driver_Access;
   end record;

end ADO.Drivers.Connections;

-----------------------------------------------------------------------
--  ADO Drivers -- Database Drivers
--  Copyright (C) 2010, 2011, 2012, 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 Ada.Finalization;

with ADO.Statements;
with ADO.Schemas;
with Util.Properties;
with Util.Strings;

--  The <b>ADO.Drivers</b> package represents the database driver that will create
--  database connections and provide the database specific implementation.
package ADO.Drivers.Connections is

   use ADO.Statements;

   type Driver is abstract tagged limited private;
   type Driver_Access is access all Driver'Class;

   --  ------------------------------
   --  Database connection implementation
   --  ------------------------------
   --
   type Database_Connection is abstract new Ada.Finalization.Limited_Controlled with record
      Count : Natural := 0;
      Ident : String (1 .. 8) := (others => ' ');
   end record;
   type Database_Connection_Access is access all Database_Connection'Class;

   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement_Access is abstract;

   function Create_Statement (Database : in Database_Connection;
                              Query    : in String)
                              return Query_Statement_Access is abstract;

   --  Create a delete statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement_Access is abstract;

   --  Create an insert statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement_Access is abstract;

   --  Create an update statement.
   function Create_Statement (Database : in Database_Connection;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement_Access is abstract;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Database_Connection) is abstract;

   --  Commit the current transaction.
   procedure Commit (Database : in out Database_Connection) is abstract;

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Database_Connection) is abstract;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Database_Connection;
                          Schema   : out ADO.Schemas.Schema_Definition) is abstract;

   --  Get the database driver which manages this connection.
   function Get_Driver (Database : in Database_Connection)
                        return Driver_Access is abstract;

   --  Closes the database connection
   procedure Close (Database : in out Database_Connection) is abstract;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Controller : in out Configuration;
                             URI        : in String);

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Controller : in out Configuration;
                           Name       : in String;
                           Value      : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Controller : in Configuration;
                          Name       : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Controller : in out Configuration;
                         Server     : in String);

   --  Get the server hostname.
   function Get_Server (Controller : in Configuration) return String;

   --  Get the server port.
   function Get_Port (Controller : in Configuration) return Integer;

   --  Get the database name.
   function Get_Database (Controller : in Configuration) return String;

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (Config : in Configuration'Class;
                                Result : out Database_Connection_Access);

   --  ------------------------------
   --  Database Driver
   --  ------------------------------

   --  Create a new connection using the configuration parameters.
   procedure Create_Connection (D      : in out Driver;
                                Config : in Configuration'Class;
                                Result : out Database_Connection_Access) is abstract;

   --  Get the driver unique index.
   function Get_Driver_Index (D : in Driver) return Driver_Index;

   --  Get the driver name.
   function Get_Driver_Name (D : in Driver) return String;

   --  Register a database driver.
   procedure Register (Driver : in Driver_Access);

   --  Get a database driver given its name.
   function Get_Driver (Name : in String) return Driver_Access;

private

   type Driver is abstract new Ada.Finalization.Limited_Controlled with record
      Name  : Util.Strings.Name_Access;
      Index : Driver_Index;
   end record;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String := Null_Unbounded_String;
      Server     : Unbounded_String := Null_Unbounded_String;
      Port       : Integer := 0;
      Database   : Unbounded_String := Null_Unbounded_String;
      Properties : Util.Properties.Manager;
      Driver     : Driver_Access;
   end record;

end ADO.Drivers.Connections;

Declare the Set_Server procedure

Declare the Set_Server procedure


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

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
      N : Natural := 0;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Console.Print_Field (F_WAN_IP, Gateway.Wan.Get ("wan.ip.address", " "));
         Print_Status (Console, F_INTERNET, Gateway.Wan.Get ("wan.internet.state", " "));
         Console.Print_Field (F_VOIP, Gateway.Voip.Get ("voip.0.status", " "));
         Print_On_Off (Console, F_WIFI, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            Console.Print_Field (F_WIFI5, "");
         else
            Print_On_Off (Console, F_WIFI5, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         end if;
         Console.Print_Field (F_ACCESS_CONTROL, Gateway.IPtv.Get ("iptv.length", "x"));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Print_Uptime (Console, F_UPTIME, Gateway.Device.Get ("device.uptime", ""));
         Console.End_Row;
         N := N + 1;
         Gateway.Hosts.Save_Properties ("sum-" & Util.Strings.Image (N) & ".properties");
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "LAN IP", 16);
      Console.Print_Title (F_WAN_IP, "WAN IP", 16);
      Console.Print_Title (F_INTERNET, "Internet", 9);
      Console.Print_Title (F_VOIP, "VoIP", 6);
      Console.Print_Title (F_WIFI, "Wifi 2.4G", 10);
      Console.Print_Title (F_WIFI5, "Wifi 5G", 10);
      Console.Print_Title (F_ACCESS_CONTROL, "Parental", 10);
      Console.Print_Title (F_DYNDNS, "DynDNS", 10);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.Print_Title (F_UPTIME, "Uptime", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Status;

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command.Do_Status (Args, Context);
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
   begin
      Put_Line ("status: Control and get status about the Bbox Wifi");
      Put_Line ("Usage: wifi {<action>} [<parameters>]");
      New_Line;
      Put_Line ("  status [IP]...         Turn ON the wifi on the Bbox.");
      Put_Line ("  wifi off [IP]...        Turn OFF the wifi on the Bbox.");
      Put_Line ("  wifi show               Show information about the wifi on the Bbox.");
      Put_Line ("  wifi devices            Show the wifi devices which are connected.");
   end Help;

end Druss.Commands.Status;

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

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_Status (Command   : in Command_Type;
                        Args      : in Argument_List'Class;
                        Context   : in out Context_Type) is
      pragma Unreferenced (Command, Args);
      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
      N : Natural := 0;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is
      begin
         Gateway.Refresh;
         Console.Start_Row;
         Console.Print_Field (F_IP_ADDR, Gateway.Ip);
         Console.Print_Field (F_WAN_IP, Gateway.Wan.Get ("wan.ip.address", " "));
         Print_Status (Console, F_INTERNET, Gateway.Wan.Get ("wan.internet.state", " "));
         Console.Print_Field (F_VOIP, Gateway.Voip.Get ("voip.0.status", " "));
         Print_On_Off (Console, F_WIFI, Gateway.Wifi.Get ("wireless.radio.24.enable", " "));
         if not Gateway.Wifi.Exists ("wireless.radio.5.enable") then
            Console.Print_Field (F_WIFI5, "");
         else
            Print_On_Off (Console, F_WIFI5, Gateway.Wifi.Get ("wireless.radio.5.enable", " "));
         end if;
         Console.Print_Field (F_ACCESS_CONTROL, Gateway.IPtv.Get ("iptv.length", "x"));
         Console.Print_Field (F_DEVICES, Gateway.Hosts.Get ("hosts.list.length", ""));
         Print_Uptime (Console, F_UPTIME, Gateway.Device.Get ("device.uptime", ""));
         Console.End_Row;
         N := N + 1;
         Gateway.Hosts.Save_Properties ("sum-" & Util.Strings.Image (N) & ".properties");
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_IP_ADDR, "LAN IP", 16);
      Console.Print_Title (F_WAN_IP, "WAN IP", 16);
      Console.Print_Title (F_INTERNET, "Internet", 9);
      Console.Print_Title (F_VOIP, "VoIP", 6);
      Console.Print_Title (F_WIFI, "Wifi 2.4G", 10);
      Console.Print_Title (F_WIFI5, "Wifi 5G", 10);
      Console.Print_Title (F_ACCESS_CONTROL, "Parental", 10);
      Console.Print_Title (F_DYNDNS, "DynDNS", 10);
      Console.Print_Title (F_DEVICES, "Devices", 12);
      Console.Print_Title (F_UPTIME, "Uptime", 12);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_Status;

   --  ------------------------------
   --  Execute a status command to report information about the Bbox.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_Status (Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "status: give information about the Bbox status");
      Console.Notice (N_HELP, "Usage: wifi {<action>} [<parameters>]");
      Console.Notice (N_HELP, "");
      Console.Notice (N_HELP, "  status [IP]...      Give information about the Bbox status");
   end Help;

end Druss.Commands.Status;

Fix compilation warnings

Fix compilation warnings


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

--  This file provides a convenient pulse width modulation (PWM) generation
--  abstract data type.

--  Example use, with arbitrary hardware selections:

--     Output : PWM_Modulator;
--
--     Initialise_PWM_Modulator
--       (Output,
--        Requested_Frequency    => 30_000.0,
--        PWM_Timer              => Timer_4'Access,
--        PWM_AF                 => GPIO_AF_TIM4,
--        Enable_PWM_Timer_Clock => RCC.TIM4_Clock_Enable'Access);
--
--     Attach_PWM_Channel
--       (Output,
--        Channel_2,
--        (GPIO_D'Access, Pin_13),  -- must match selected channel
--        RCC.GPIOD_Clock_Enable'Access);
--
--     Enable_PWM_Channel (Output, Channel_2);
--
--     Set_Duty_Cycle (Output, Channel_2, Value);

with STM32.GPIO;   use STM32.GPIO;
with STM32.Timers; use STM32.Timers;

package STM32.PWM is
   pragma Elaborate_Body;

   type PWM_Modulator is limited private;

   procedure Initialise_PWM_Modulator
     (This                   : in out PWM_Modulator;
      Requested_Frequency    : Float;
      PWM_Timer              : not null access Timer;
      PWM_AF                 : GPIO_Alternate_Function)
     with Post =>
       (for all Channel in Timer_Channel => (not Attached (This, Channel)));
   --  Initializes the specified timer for PWM generation at the requested
   --  frequency. You must attach at least one channel to the modulator in
   --  order to drive PWM output values.

   procedure Attach_PWM_Channel
     (This                   : in out PWM_Modulator;
      Channel                : Timer_Channel;
      Point                  : GPIO_Point)
     with Post => Attached (This, Channel) and
                  not Enabled (This, Channel) and
                  Current_Duty_Cycle (This, Channel) = 0;
   --  Initializes the channel on the timer associated with This, and the
   --  corresponding GPIO port/pin pair, for PWM output. May be called multiple
   --  times for the same PWM_Modulator object, with different channels,
   --  because the corresponding timer can drive multiple channels (assuming
   --  such a timer is in use).

   procedure Enable_PWM_Channel
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel)
     with Post => Enabled (This, Channel);

   function Enabled
     (This    : PWM_Modulator;
      Channel : Timer_Channel)
      return Boolean;

   procedure Disable_PWM_Channel
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel)
     with Post => not Enabled (This, Channel);

   subtype Percentage is Integer range 0 .. 100;

   procedure Set_Duty_Cycle
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel;
      Value   : Percentage)
     with
       Inline,
       Pre  => (Attached (This, Channel) or else raise Not_Attached) and
               Enabled (This, Channel),
       Post => Current_Duty_Cycle (This, Channel) = Value;
   --  Sets the pulse width such that the requested percentage is achieved.

   function Current_Duty_Cycle
     (This : PWM_Modulator; Channel : Timer_Channel)
      return Percentage
     with Inline,
          Pre => Attached (This, Channel) or else raise Not_Attached;

   subtype Microseconds is Word;

   procedure Set_Duty_Time
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel;
      Value   : Microseconds)
     with
       Inline,
       Pre => (Attached (This, Channel) or else raise Not_Attached) and
              Enabled (This, Channel);
   --  Set the pulse width such that the requested number of microseconds is
   --  achieved. Raises Invalid_Request if the requested time is greater than
   --  the period previously configured via Initialise_PWM_Modulator.

   Invalid_Request : exception;
   --  Raised when the requested frequency is too high or too low for the given
   --  timer and system clocks when calling Initialize_PWM_Modulator, or when
   --  the requested time is too high for the specified frequency when calling
   --  Set_Duty_Time

   Unknown_Timer : exception;
   --  Raised if a timer that is not physically present is passed to
   --  Initialize_PWM_Modulator

   Not_Attached : exception;

   function Attached
     (This    : PWM_Modulator;
      Channel : Timer_Channel)
      return Boolean;

private

   type PWM_Output is record
      Duty_Cycle : Percentage := 0;
      Attached   : Boolean := False;
   end record;

   type PWM_Outputs is array (Timer_Channel) of PWM_Output;

   type PWM_Modulator is record
      Output_Timer : access Timer;
      Outputs      : PWM_Outputs;
      Timer_Period : Word;
      Frequency    : Word;
      AF           : GPIO_Alternate_Function;
   end record;

end STM32.PWM;

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

--  This file provides a convenient pulse width modulation (PWM) generation
--  abstract data type.

--  Example use, with arbitrary hardware selections:

--     Output : PWM_Modulator;
--
--     Initialise_PWM_Modulator
--       (Output,
--        Requested_Frequency    => 30_000.0,
--        PWM_Timer              => Timer_4'Access,
--        PWM_AF                 => GPIO_AF_TIM4,
--        Enable_PWM_Timer_Clock => RCC.TIM4_Clock_Enable'Access);
--
--     Attach_PWM_Channel
--       (Output,
--        Channel_2,
--        (GPIO_D'Access, Pin_13),  -- must match selected channel
--        RCC.GPIOD_Clock_Enable'Access);
--
--     Enable_PWM_Channel (Output, Channel_2);
--
--     Set_Duty_Cycle (Output, Channel_2, Value);

with STM32.GPIO;   use STM32.GPIO;
with STM32.Timers; use STM32.Timers;

package STM32.PWM is
   pragma Elaborate_Body;

   type PWM_Modulator is limited private;

   procedure Initialise_PWM_Modulator
     (This                   : in out PWM_Modulator;
      Requested_Frequency    : Float;
      PWM_Timer              : not null access Timer;
      PWM_AF                 : GPIO_Alternate_Function)
     with Post =>
       (for all Channel in Timer_Channel => (not Attached (This, Channel)));
   --  Initializes the specified timer for PWM generation at the requested
   --  frequency. You must attach at least one channel to the modulator in
   --  order to drive PWM output values.

   procedure Attach_PWM_Channel
     (This                   : in out PWM_Modulator;
      Channel                : Timer_Channel;
      Point                  : GPIO_Point)
     with Post => Attached (This, Channel) and
                  not Enabled (This, Channel) and
                  Current_Duty_Cycle (This, Channel) = 0;
   --  Initializes the channel on the timer associated with This, and the
   --  corresponding GPIO port/pin pair, for PWM output. May be called multiple
   --  times for the same PWM_Modulator object, with different channels,
   --  because the corresponding timer can drive multiple channels (assuming
   --  such a timer is in use).

   procedure Enable_PWM_Channel
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel)
     with Post => Enabled (This, Channel);

   function Enabled
     (This    : PWM_Modulator;
      Channel : Timer_Channel)
      return Boolean;

   procedure Disable_PWM_Channel
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel)
     with Post => not Enabled (This, Channel);

   subtype Percentage is Integer range 0 .. 100;

   procedure Set_Duty_Cycle
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel;
      Value   : Percentage)
     with
       Inline,
       Pre  => (Attached (This, Channel) or else raise Not_Attached),
       Post => Current_Duty_Cycle (This, Channel) = Value;
   --  Sets the pulse width such that the requested percentage is achieved.

   function Current_Duty_Cycle
     (This : PWM_Modulator; Channel : Timer_Channel)
      return Percentage
     with Inline,
          Pre => Attached (This, Channel) or else raise Not_Attached;

   subtype Microseconds is Word;

   procedure Set_Duty_Time
     (This    : in out PWM_Modulator;
      Channel : Timer_Channel;
      Value   : Microseconds)
     with
       Inline,
       Pre => (Attached (This, Channel) or else raise Not_Attached);
   --  Set the pulse width such that the requested number of microseconds is
   --  achieved. Raises Invalid_Request if the requested time is greater than
   --  the period previously configured via Initialise_PWM_Modulator.

   Invalid_Request : exception;
   --  Raised when the requested frequency is too high or too low for the given
   --  timer and system clocks when calling Initialize_PWM_Modulator, or when
   --  the requested time is too high for the specified frequency when calling
   --  Set_Duty_Time

   Unknown_Timer : exception;
   --  Raised if a timer that is not physically present is passed to
   --  Initialize_PWM_Modulator

   Not_Attached : exception;

   function Attached
     (This    : PWM_Modulator;
      Channel : Timer_Channel)
      return Boolean;

private

   type PWM_Output is record
      Duty_Cycle : Percentage := 0;
      Attached   : Boolean := False;
   end record;

   type PWM_Outputs is array (Timer_Channel) of PWM_Output;

   type PWM_Modulator is record
      Output_Timer : access Timer;
      Outputs      : PWM_Outputs;
      Timer_Period : Word;
      Frequency    : Word;
      AF           : GPIO_Alternate_Function;
   end record;

end STM32.PWM;

Remove Enabled as precondition for PWM set duty procedures

The channel doesn't need to be enabled before setting duty value and it
can be useful to set a value before enabling it.