-----------------------------------------------------------------------
--  util-log-appenders -- Log appenders
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2015, 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 Ada.Text_IO;
with Ada.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;
with Util.Properties;
limited with Util.Log.Loggers;

--  The log Appender will handle the low level operations to write
--  the log content to a file, the console, a database.
package Util.Log.Appenders is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Log event
   --  ------------------------------
   --  The Log_Event represent a log message reported by one of the
   --  log operation (Debug, Info, Warn, Error).
   type Log_Event is record
      --  The log message (formatted)
      Message : Unbounded_String;

      --  The timestamp when the message was produced.
      Time    : Ada.Calendar.Time;

      --  The log level
      Level   : Level_Type;

      --  The logger
      Logger  : access Util.Log.Loggers.Logger_Info;
   end record;

   --  The layout type to indicate how to format the message.
   --  Unlike Logj4, there is no customizable layout.
   type Layout_Type
     is (
         --  The message layout with only the log message.
         --  Ex: "Cannot open file"
         MESSAGE,

         --  The level-message layout with level and message.
         --  Ex: "ERROR: Cannot open file"
         LEVEL_MESSAGE,

         --  The date-level-message layout with date
         --  Ex: "2011-03-04 12:13:34 ERROR: Cannot open file"
         DATE_LEVEL_MESSAGE,

         --  The full layout with everything (the default).
         --  Ex: "2011-03-04 12:13:34 ERROR - my.application - Cannot open file"
         FULL);

   --  ------------------------------
   --  Log appender
   --  ------------------------------
   type Appender is abstract new Ada.Finalization.Limited_Controlled with private;

   type Appender_Access is access all Appender'Class;

   --  Get the log level that triggers display of the log events
   function Get_Level (Self : in Appender) return Level_Type;

   --  Set the log level.
   procedure Set_Level (Self       : in out Appender;
                        Name       : in String;
                        Properties : in Util.Properties.Manager;
                        Level      : in Level_Type);

   --  Set the log layout format.
   procedure Set_Layout (Self       : in out Appender;
                         Name       : in String;
                         Properties : in Util.Properties.Manager;
                         Layout     : in Layout_Type);

   --  Format the event into a string
   function Format (Self  : in Appender;
                    Event : in Log_Event) return String;

   --  Append a log event to the appender.  Depending on the log level
   --  defined on the appender, the event can be taken into account or
   --  ignored.
   procedure Append (Self  : in out Appender;
                     Event : in Log_Event) is abstract;

   --  Flush the log events.
   procedure Flush (Self   : in out Appender) is abstract;

   --  ------------------------------
   --  File appender
   --  ------------------------------
   --  Write log events to a file
   type File_Appender is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

   overriding
   procedure Append (Self  : in out File_Appender;
                     Event : in Log_Event);

   --  Set the file where the appender will write the logs.
   --  When <tt>Append</tt> is true, the log message are appended to the existing file.
   --  When set to false, the file is cleared before writing new messages.
   procedure Set_File (Self   : in out File_Appender;
                       Path   : in String;
                       Append : in Boolean := True);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create_File_Appender (Name       : in String;
                                  Properties : in Util.Properties.Manager;
                                  Default    : in Level_Type)
     return Appender_Access;

   --  ------------------------------
   --  Console appender
   --  ------------------------------
   --  Write log events to the console
   type Console_Appender is new Appender with private;
   type Console_Appender_Access is access all Console_Appender'Class;

   overriding
   procedure Append (Self  : in out Console_Appender;
                     Event : in Log_Event);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out Console_Appender);

   --  Create a console appender and configure it according to the properties
   function Create_Console_Appender (Name       : in String;
                                     Properties : in Util.Properties.Manager;
                                     Default    : in Level_Type)
                                     return Appender_Access;

   --  ------------------------------
   --  List appender
   --  ------------------------------
   --  Write log events to a list of appenders
   type List_Appender is new Appender with private;
   type List_Appender_Access is access all List_Appender'Class;

   --  Max number of appenders that can be added to the list.
   --  In most cases, 2 or 3 appenders will be used.
   MAX_APPENDERS : constant Natural := 10;

   overriding
   procedure Append (Self  : in out List_Appender;
                     Event : in Log_Event);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out List_Appender);

   --  Add the appender to the list.
   procedure Add_Appender (Self   : in out List_Appender;
                           Object : in Appender_Access);

   --  Create a list appender and configure it according to the properties
   function Create_List_Appender return List_Appender_Access;

private

   type Appender is abstract new Ada.Finalization.Limited_Controlled with record
      Level    : Level_Type := INFO_LEVEL;
      Layout   : Layout_Type := FULL;
   end record;

   type File_Appender is new Appender with record
      Output          : Ada.Text_IO.File_Type;
      Immediate_Flush : Boolean := False;
   end record;

   type Appender_Array_Access is array (1 .. MAX_APPENDERS) of Appender_Access;

   type List_Appender is new Appender with record
      Appenders : Appender_Array_Access;
      Count     : Natural := 0;
   end record;

   type Console_Appender is new Appender with null record;

end Util.Log.Appenders;

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

--  The log Appender will handle the low level operations to write
--  the log content to a file, the console, a database.
package Util.Log.Appenders is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Log event
   --  ------------------------------
   --  The Log_Event represent a log message reported by one of the
   --  log operation (Debug, Info, Warn, Error).
   type Log_Event is record
      --  The log message (formatted)
      Message : Unbounded_String;

      --  The timestamp when the message was produced.
      Time    : Ada.Calendar.Time;

      --  The log level
      Level   : Level_Type;

      --  The logger
      Logger  : access Util.Log.Loggers.Logger_Info;
   end record;

   --  The layout type to indicate how to format the message.
   --  Unlike Logj4, there is no customizable layout.
   type Layout_Type
     is (
         --  The message layout with only the log message.
         --  Ex: "Cannot open file"
         MESSAGE,

         --  The level-message layout with level and message.
         --  Ex: "ERROR: Cannot open file"
         LEVEL_MESSAGE,

         --  The date-level-message layout with date
         --  Ex: "2011-03-04 12:13:34 ERROR: Cannot open file"
         DATE_LEVEL_MESSAGE,

         --  The full layout with everything (the default).
         --  Ex: "2011-03-04 12:13:34 ERROR - my.application - Cannot open file"
         FULL);

   --  ------------------------------
   --  Log appender
   --  ------------------------------
   type Appender is abstract new Ada.Finalization.Limited_Controlled with private;

   type Appender_Access is access all Appender'Class;

   --  Get the log level that triggers display of the log events
   function Get_Level (Self : in Appender) return Level_Type;

   --  Set the log level.
   procedure Set_Level (Self       : in out Appender;
                        Name       : in String;
                        Properties : in Util.Properties.Manager;
                        Level      : in Level_Type);

   --  Set the log layout format.
   procedure Set_Layout (Self       : in out Appender;
                         Name       : in String;
                         Properties : in Util.Properties.Manager;
                         Layout     : in Layout_Type);

   --  Format the event into a string
   function Format (Self  : in Appender;
                    Event : in Log_Event) return String;

   --  Append a log event to the appender.  Depending on the log level
   --  defined on the appender, the event can be taken into account or
   --  ignored.
   procedure Append (Self  : in out Appender;
                     Event : in Log_Event) is abstract;

   --  Flush the log events.
   procedure Flush (Self   : in out Appender) is abstract;

   --  ------------------------------
   --  File appender
   --  ------------------------------
   --  Write log events to a file
   type File_Appender is new Appender with private;
   type File_Appender_Access is access all File_Appender'Class;

   overriding
   procedure Append (Self  : in out File_Appender;
                     Event : in Log_Event);

   --  Set the file where the appender will write the logs.
   --  When <tt>Append</tt> is true, the log message are appended to the existing file.
   --  When set to false, the file is cleared before writing new messages.
   procedure Set_File (Self   : in out File_Appender;
                       Path   : in String;
                       Append : in Boolean := True);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out File_Appender);

   --  Flush and close the file.
   overriding
   procedure Finalize (Self : in out File_Appender);

   --  Create a file appender and configure it according to the properties
   function Create_File_Appender (Name       : in String;
                                  Properties : in Util.Properties.Manager;
                                  Default    : in Level_Type)
     return Appender_Access;

   --  ------------------------------
   --  Console appender
   --  ------------------------------
   --  Write log events to the console
   type Console_Appender is new Appender with private;
   type Console_Appender_Access is access all Console_Appender'Class;

   overriding
   procedure Append (Self  : in out Console_Appender;
                     Event : in Log_Event);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out Console_Appender);

   --  Create a console appender and configure it according to the properties
   function Create_Console_Appender (Name       : in String;
                                     Properties : in Util.Properties.Manager;
                                     Default    : in Level_Type)
                                     return Appender_Access;

   --  ------------------------------
   --  List appender
   --  ------------------------------
   --  Write log events to a list of appenders
   type List_Appender is new Appender with private;
   type List_Appender_Access is access all List_Appender'Class;

   --  Max number of appenders that can be added to the list.
   --  In most cases, 2 or 3 appenders will be used.
   MAX_APPENDERS : constant Natural := 10;

   overriding
   procedure Append (Self  : in out List_Appender;
                     Event : in Log_Event);

   --  Flush the log events.
   overriding
   procedure Flush (Self   : in out List_Appender);

   --  Add the appender to the list.
   procedure Add_Appender (Self   : in out List_Appender;
                           Object : in Appender_Access);

   --  Create a list appender and configure it according to the properties
   function Create_List_Appender return List_Appender_Access;

private

   type Appender is abstract new Ada.Finalization.Limited_Controlled with record
      Level    : Level_Type := INFO_LEVEL;
      Layout   : Layout_Type := FULL;
   end record;

   type File_Appender is new Appender with record
      Output          : Ada.Text_IO.File_Type;
      Immediate_Flush : Boolean := False;
   end record;

   type Appender_Array_Access is array (1 .. MAX_APPENDERS) of Appender_Access;

   type List_Appender is new Appender with record
      Appenders : Appender_Array_Access;
      Count     : Natural := 0;
   end record;

   type Console_Appender is new Appender with record
      Output : Ada.Text_IO.File_Access;
   end record;

end Util.Log.Appenders;

Add Output member to the console appender


-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 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 Ada.Calendar;
with Util.Properties;

--  === JSON Web Token ===
--  JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred
--  between two parties.  A JWT token is returned by an authorization server.  It contains
--  useful information that allows to verify the authentication and identify the user.
--
--  The <tt>Security.OAuth.JWT</tt> package implements the decoding part of JWT defined in:
--  JSON Web Token (JWT), http://tools.ietf.org/html/draft-ietf-oauth-json-web-token-07
--
--  A list of pre-defined ID tokens are returned in the JWT token claims and used for
--  the OpenID Connect.  This is specified in
--  OpenID Connect Basic Client Profile 1.0 - draft 26,
--  http://openid.net/specs/openid-connect-basic-1_0.html
--
package Security.OAuth.JWT is

   --  Exception raised if the encoded token is invalid or cannot be decoded.
   Invalid_Token : exception;

   type Token is private;

   --  Get the issuer claim from the token (the "iss" claim).
   function Get_Issuer (From : in Token) return String;

   --  Get the subject claim from the token (the "sub" claim).
   function Get_Subject (From : in Token) return String;

   --  Get the audience claim from the token (the "aud" claim).
   function Get_Audience (From : in Token) return String;

   --  Get the expiration claim from the token (the "exp" claim).
   function Get_Expiration (From : in Token) return Ada.Calendar.Time;

   --  Get the not before claim from the token (the "nbf" claim).
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time;

   --  Get the issued at claim from the token (the "iat" claim).
   --  This is the time when the JWT was issued.
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time;

   --  Get the authentication time claim from the token (the "auth_time" claim).
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time;

   --  Get the JWT ID claim from the token (the "jti" claim).
   function Get_JWT_ID (From : in Token) return String;

   --  Get the authorized clients claim from the token (the "azp" claim).
   function Get_Authorized_Presenters (From : in Token) return String;

   --  Get the claim with the given name from the token.
   function Get_Claim (From : in Token;
                       Name : in String) return String;

   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   function Decode (Content : in String) return Token;

private

   type Claims is new Util.Properties.Manager with null record;

   type Token is record
      Header : Util.Properties.Manager;
      Claims : Util.Properties.Manager;
   end record;

end Security.OAuth.JWT;

-----------------------------------------------------------------------
--  security-oauth-jwt -- OAuth Java Web Token
--  Copyright (C) 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 Ada.Calendar;
with Util.Properties;

--  === JSON Web Token ===
--  JSON Web Token (JWT) is a compact URL-safe means of representing claims to be transferred
--  between two parties.  A JWT token is returned by an authorization server.  It contains
--  useful information that allows to verify the authentication and identify the user.
--
--  The <tt>Security.OAuth.JWT</tt> package implements the decoding part of JWT defined in:
--  JSON Web Token (JWT), http://tools.ietf.org/html/draft-ietf-oauth-json-web-token-07
--
--  A list of pre-defined ID tokens are returned in the JWT token claims and used for
--  the OpenID Connect.  This is specified in
--  OpenID Connect Basic Client Profile 1.0 - draft 26,
--  http://openid.net/specs/openid-connect-basic-1_0.html
--
package Security.OAuth.JWT is

   --  Exception raised if the encoded token is invalid or cannot be decoded.
   Invalid_Token : exception;

   type Token is private;

   --  Get the issuer claim from the token (the "iss" claim).
   function Get_Issuer (From : in Token) return String;

   --  Get the subject claim from the token (the "sub" claim).
   function Get_Subject (From : in Token) return String;

   --  Get the audience claim from the token (the "aud" claim).
   function Get_Audience (From : in Token) return String;

   --  Get the expiration claim from the token (the "exp" claim).
   function Get_Expiration (From : in Token) return Ada.Calendar.Time;

   --  Get the not before claim from the token (the "nbf" claim).
   function Get_Not_Before (From : in Token) return Ada.Calendar.Time;

   --  Get the issued at claim from the token (the "iat" claim).
   --  This is the time when the JWT was issued.
   function Get_Issued_At (From : in Token) return Ada.Calendar.Time;

   --  Get the authentication time claim from the token (the "auth_time" claim).
   function Get_Authentication_Time (From : in Token) return Ada.Calendar.Time;

   --  Get the JWT ID claim from the token (the "jti" claim).
   function Get_JWT_ID (From : in Token) return String;

   --  Get the authorized clients claim from the token (the "azp" claim).
   function Get_Authorized_Presenters (From : in Token) return String;

   --  Get the claim with the given name from the token.
   function Get_Claim (From    : in Token;
                       Name    : in String;
                       Default : in String := "") return String;

   --  Decode a string representing an encoded JWT token according to the JWT specification:
   --
   --    Section 7.  Rules for Creating and Validating a JWT
   --
   --  The JWT token is composed of 3 parts encoded in Base64url and separated by '.' .
   --  The first part represents the header, the second part the claims and the last part
   --  the signature.  The <tt>Decode</tt> operation splits the parts, decodes them,
   --  parses the JSON content represented by the header and the claims.
   --  The <tt>Decode</tt> operation does not verify the signature (yet!).
   --
   --  Return the decoded token or raise an exception.
   function Decode (Content : in String) return Token;

private

   type Claims is new Util.Properties.Manager with null record;

   type Token is record
      Header : Util.Properties.Manager;
      Claims : Util.Properties.Manager;
   end record;

end Security.OAuth.JWT;

Update Get_Claim to add a default value returned if the claim does not exist


------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Templates.Integers;
with Natools.Static_Maps.S_Expressions.Templates.Integers.T;

package body Natools.S_Expressions.Templates.Tests.Integers is

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String);
   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String);
      --  Run Template with Value and compare the result with Expected

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Defaults, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Alignment (Report);
      Default_Format (Report);
      Explicit_Images (Report);
      Explicit_Sign (Report);
      Hexadecimal (Report);
      Overflow (Report);
      Parse_Errors (Report);
      Static_Hash_Map (Report);
      Explicit_Default_Format (Report);
      Prefix_And_Suffix (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Alignment (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "(width 5)", 0, "    0");
      Test_Render (Test, "(width 5)(padding _)(align center)", 10, "_10__");
      Test_Render (Test, "(width 5 10)(left-align)", 7, "7    ");
      Test_Render (Test, "(min-width 5)(right-align)", 2, "    2");
      Test_Render (Test, "(width 5)(padding > <)(centered)", 4, ">>4<<");
      Test_Render
        (Test,
         "(width 5)(left-padding ""["")(right-padding ""]"")(centered)",
         126,
         "[126]");
      Test_Render (Test, "(width 3)(centered)", 16, "16 ");
      Test_Render (Test, "(width 3)(centered)", 456, "456");
      Test_Render (Test, "(width 3)(align left)", 567, "567");
      Test_Render (Test, "(width 3)(align right)", 678, "678");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Alignment;

   procedure Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "", 42, "42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Format;

   procedure Explicit_Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Client-provided default format");
   begin
      declare
         Default : Templates.Integers.Format;
      begin
         Default.Set_Minimum_Width (2);
         Default.Set_Left_Padding (To_Atom ("0"));

         Test_Render (Test, Default, "", 5, "05");
         Test_Render (Test, Default, "", 12, "12");
         Test_Render (Test, Default, "(padding 1: )", 7, " 7");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Default_Format;

   procedure Explicit_Images (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit images in template");
   begin
      Test_Render (Test, "(image (-2 two) (666 evil))", 10, "10");
      Test_Render (Test, "(image (-2 two) (666 evil))", -2, "two");
      Test_Render (Test, "(image (-2 two) (666 evil))", 666, "evil");
      Test_Render (Test, "(image (-2 two) (666 evil) (-2))", -2, "-2");
      Test_Render (Test, "(image (1 one))3:Two4:four", 1, "one");
      Test_Render (Test, "(image (1 one))3:Two4:four", 2, "Two");
      Test_Render (Test, "(image (1 one))3:Two4:four", 3, "four");
      Test_Render (Test, "(image (1 one))3:Two4:four", 4, "4");
      Test_Render (Test, "(image (invalid -))5:first", Integer'First, "first");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Images;

   procedure Explicit_Sign (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit sign specification");
   begin
      Test_Render (Test, "(sign +)", 42, "+42");
      Test_Render (Test, "(sign + _)", 42, "+42");
      Test_Render (Test, "(sign + _)", -42, "_42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Sign;

   procedure Hexadecimal (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Hexadecimal representation");
      Hex_Spec : constant String
        := "(base 0 1 2 3 4 5 6 7 8 9 A B C D E F)";
   begin
      Test_Render (Test, Hex_Spec, 8, "8");
      Test_Render (Test, Hex_Spec, 16#BEE#, "BEE");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Hexadecimal;

   procedure Overflow (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Width overflow");
   begin
      Test_Render (Test, "(width 3)", 10_000, "");
      Test_Render (Test, "(max-width 4)", 10_000, "");
      Test_Render (Test, "(max-width 3 ""[...]"")", 10_000, "[...]");
      Test_Render (Test, "(width 2 3 ...)", 10_000, "...");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Overflow;

   procedure Parse_Errors (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      Test_Render (Test, "(invalid-command)", 1, "1");
      Test_Render (Test, "(align)", 2, "2");
      Test_Render (Test, "(align invalid)", 3, "3");
      Test_Render (Test, "(padding)", 4, "4");
      Test_Render (Test, "(left-padding)", 5, "5");
      Test_Render (Test, "(right-padding)", 6, "6");
      Test_Render (Test, "(signs)", 7, "7");
      Test_Render (Test, "(width)", 8, "8");
      Test_Render (Test, "(max-width)", 9, "9");
      Test_Render (Test, "(min-width)", 10, "10");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Parse_Errors;

   procedure Prefix_And_Suffix (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
      Ordinal : constant String
        := "(suffix 1:? (th (0 31)) (st 1 21 31) (nd 2 22) (rd 3 23) (0: 0))";
   begin
      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Prefix ((0, 9), To_Atom ("a"));
         Format.Set_Prefix ((-99, -10), To_Atom ("b"));
         Format.Set_Prefix ((50, 99), To_Atom ("c"));
         Format.Set_Prefix (0, To_Atom ("d"));
         Format.Set_Prefix (-10, To_Atom ("e"));
         Format.Set_Prefix (5, To_Atom ("f"));
         Format.Set_Prefix ((7, 52), To_Atom ("g"));
         Format.Set_Prefix ((-52, -49), To_Atom ("h"));
         Format.Set_Prefix ((-100, -90), To_Atom ("i"));
         Format.Remove_Prefix (8);

         Test_Render (Test, Format, "", -196, "-196");
         Test_Render (Test, Format, "", -101, "-101");
         Test_Render (Test, Format, "", -100, "i-100");
         Test_Render (Test, Format, "", -90, "i-90");
         Test_Render (Test, Format, "", -89, "b-89");
         Test_Render (Test, Format, "", -53, "b-53");
         Test_Render (Test, Format, "", -52, "h-52");
         Test_Render (Test, Format, "", -49, "h-49");
         Test_Render (Test, Format, "", -48, "b-48");
         Test_Render (Test, Format, "", -11, "b-11");
         Test_Render (Test, Format, "", -10, "e-10");
         Test_Render (Test, Format, "", -9, "-9");
         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "d0");
         Test_Render (Test, Format, "", 1, "a1");
         Test_Render (Test, Format, "", 4, "a4");
         Test_Render (Test, Format, "", 5, "f5");
         Test_Render (Test, Format, "", 6, "a6");
         Test_Render (Test, Format, "", 7, "g7");
         Test_Render (Test, Format, "", 8, "8");
         Test_Render (Test, Format, "", 9, "g9");
         Test_Render (Test, Format, "", 52, "g52");
         Test_Render (Test, Format, "", 53, "c53");
         Test_Render (Test, Format, "", 99, "c99");
         Test_Render (Test, Format, "", 100, "100");
         Test_Render (Test, Format, "", 192, "192");
      end;

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Suffix ((0, 10), To_Atom ("th"));
         Format.Set_Suffix (1, To_Atom ("st"));
         Format.Remove_Suffix (0);

         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "0");
         Test_Render (Test, Format, "", 1, "1st");
         Test_Render (Test, Format, "", 4, "4th");
         Test_Render (Test, Format, "", 10, "10th");
      end;

      Test_Render (Test, Ordinal, -1, "-1?");
      Test_Render (Test, Ordinal, 0, "0");
      Test_Render (Test, Ordinal, 1, "1st");
      Test_Render (Test, Ordinal, 2, "2nd");
      Test_Render (Test, Ordinal, 3, "3rd");
      Test_Render (Test, Ordinal, 4, "4th");

      Test_Render (Test, "(prefix (a) (b invalid (9 5)))", 0, "0");
      Test_Render (Test, "(prefix (c (invalid 5) (-1 invalid)))", 0, "0");
      Test_Render (Test, "(prefix (d ((invalid) 5) (-1)) ())", 0, "0");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Prefix_And_Suffix;

   procedure Static_Hash_Map (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      if not Natools.Static_Maps.S_Expressions.Templates.Integers.T then
         Test.Fail;
      end if;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Static_Hash_Map;

end Natools.S_Expressions.Templates.Tests.Integers;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Templates.Integers;
with Natools.Static_Maps.S_Expressions.Templates.Integers.T;

package body Natools.S_Expressions.Templates.Tests.Integers is

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String);
   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String);
      --  Run Template with Value and compare the result with Expected

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Test_Render
     (Test : in out NT.Test;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   procedure Test_Render
     (Test : in out NT.Test;
      Defaults : in Templates.Integers.Format;
      Template : in String;
      Value : in Integer;
      Expected : in String)
   is
      Input : aliased Test_Tools.Memory_Stream;
      Output : Test_Tools.Memory_Stream;
      Parser : Parsers.Stream_Parser (Input'Access);
   begin
      Input.Set_Data (To_Atom (Template));
      Parser.Next;
      Output.Set_Expected (To_Atom (Expected));
      Templates.Integers.Render (Output, Defaults, Parser, Value);
      Output.Check_Stream (Test);
   end Test_Render;

   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Alignment (Report);
      Default_Format (Report);
      Explicit_Images (Report);
      Explicit_Sign (Report);
      Hexadecimal (Report);
      Overflow (Report);
      Parse_Errors (Report);
      Static_Hash_Map (Report);
      Explicit_Default_Format (Report);
      Prefix_And_Suffix (Report);
   end All_Tests;

   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Alignment (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "(width 5)", 0, "    0");
      Test_Render (Test, "(width 5)(padding _)(align center)", 10, "_10__");
      Test_Render (Test, "(width 5 10)(left-align)", 7, "7    ");
      Test_Render (Test, "(min-width 5)(right-align)", 2, "    2");
      Test_Render (Test, "(width 5)(padding > <)(centered)", 4, ">>4<<");
      Test_Render
        (Test,
         "(width 5)(left-padding ""["")(right-padding ""]"")(centered)",
         126,
         "[126]");
      Test_Render (Test, "(width 3)(centered)", 16, "16 ");
      Test_Render (Test, "(width 3)(centered)", 456, "456");
      Test_Render (Test, "(width 3)(align left)", 567, "567");
      Test_Render (Test, "(width 3)(align right)", 678, "678");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Alignment;

   procedure Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Debug instantiation");
   begin
      Test_Render (Test, "", 42, "42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Default_Format;

   procedure Explicit_Default_Format (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Client-provided default format");
   begin
      declare
         Default : Templates.Integers.Format;
      begin
         Default.Set_Minimum_Width (2);
         Default.Set_Left_Padding (To_Atom ("0"));

         Test_Render (Test, Default, "", 5, "05");
         Test_Render (Test, Default, "", 12, "12");
         Test_Render (Test, Default, "(padding 1: )", 7, " 7");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Default_Format;

   procedure Explicit_Images (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit images in template");
   begin
      Test_Render (Test, "(image (-2 two) (666 evil))", 10, "10");
      Test_Render (Test, "(image (-2 two) (666 evil))", -2, "two");
      Test_Render (Test, "(image (-2 two) (666 evil))", 666, "evil");
      Test_Render (Test, "(image (-2 two) (666 evil) (-2))", -2, "-2");
      Test_Render (Test, "(image (1 one))3:Two4:four", 1, "one");
      Test_Render (Test, "(image (1 one))3:Two4:four", 2, "Two");
      Test_Render (Test, "(image (1 one))3:Two4:four", 3, "four");
      Test_Render (Test, "(image (1 one))3:Two4:four", 4, "4");
      Test_Render (Test, "(image (invalid -))5:first", Integer'First, "first");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Images;

   procedure Explicit_Sign (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Explicit sign specification");
   begin
      Test_Render (Test, "(sign +)", 42, "+42");
      Test_Render (Test, "(sign + _)", 42, "+42");
      Test_Render (Test, "(sign + _)", -42, "_42");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Explicit_Sign;

   procedure Hexadecimal (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Hexadecimal representation");
      Hex_Spec : constant String
        := "(base 0 1 2 3 4 5 6 7 8 9 A B C D E F)";
   begin
      Test_Render (Test, Hex_Spec, 8, "8");
      Test_Render (Test, Hex_Spec, 16#BEE#, "BEE");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Hexadecimal;

   procedure Overflow (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Width overflow");
   begin
      Test_Render (Test, "(width 3)", 10_000, "");
      Test_Render (Test, "(max-width 4)", 10_000, "");
      Test_Render (Test, "(max-width 3 ""[...]"")", 10_000, "[...]");
      Test_Render (Test, "(width 2 3 ...)", 10_000, "...");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Overflow;

   procedure Parse_Errors (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      Test_Render (Test, "(invalid-command)", 1, "1");
      Test_Render (Test, "(align)", 2, "2");
      Test_Render (Test, "(align invalid)", 3, "3");
      Test_Render (Test, "(padding)", 4, "4");
      Test_Render (Test, "(left-padding)", 5, "5");
      Test_Render (Test, "(right-padding)", 6, "6");
      Test_Render (Test, "(signs)", 7, "7");
      Test_Render (Test, "(width)", 8, "8");
      Test_Render (Test, "(max-width)", 9, "9");
      Test_Render (Test, "(min-width)", 10, "10");
   exception
      when Error : others => Test.Report_Exception (Error);
   end Parse_Errors;

   procedure Prefix_And_Suffix (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
      Ordinal : constant String
        := "(suffix 1:? (th (0 31)) (st 1 21 31) (nd 2 22) (rd 3 23) (0: 0))";
   begin
      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Prefix ((0, 9), To_Atom ("a"));
         Format.Set_Prefix ((-99, -10), To_Atom ("b"));
         Format.Set_Prefix ((50, 99), To_Atom ("c"));
         Format.Set_Prefix (0, To_Atom ("d"));
         Format.Set_Prefix (-10, To_Atom ("e"));
         Format.Set_Prefix (5, To_Atom ("f"));
         Format.Set_Prefix ((7, 52), To_Atom ("g"));
         Format.Set_Prefix ((-52, -49), To_Atom ("h"));
         Format.Set_Prefix ((-100, -90), To_Atom ("i"));
         Format.Remove_Prefix (8);

         Test_Render (Test, Format, "", -196, "-196");
         Test_Render (Test, Format, "", -101, "-101");
         Test_Render (Test, Format, "", -100, "i-100");
         Test_Render (Test, Format, "", -90, "i-90");
         Test_Render (Test, Format, "", -89, "b-89");
         Test_Render (Test, Format, "", -53, "b-53");
         Test_Render (Test, Format, "", -52, "h-52");
         Test_Render (Test, Format, "", -49, "h-49");
         Test_Render (Test, Format, "", -48, "b-48");
         Test_Render (Test, Format, "", -11, "b-11");
         Test_Render (Test, Format, "", -10, "e-10");
         Test_Render (Test, Format, "", -9, "-9");
         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "d0");
         Test_Render (Test, Format, "", 1, "a1");
         Test_Render (Test, Format, "", 4, "a4");
         Test_Render (Test, Format, "", 5, "f5");
         Test_Render (Test, Format, "", 6, "a6");
         Test_Render (Test, Format, "", 7, "g7");
         Test_Render (Test, Format, "", 8, "8");
         Test_Render (Test, Format, "", 9, "g9");
         Test_Render (Test, Format, "", 52, "g52");
         Test_Render (Test, Format, "", 53, "c53");
         Test_Render (Test, Format, "", 99, "c99");
         Test_Render (Test, Format, "", 100, "100");
         Test_Render (Test, Format, "", 192, "192");
      end;

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Suffix ((0, 10), To_Atom ("th"));
         Format.Set_Suffix (1, To_Atom ("st"));
         Format.Remove_Suffix (0);

         Test_Render (Test, Format, "", -1, "-1");
         Test_Render (Test, Format, "", 0, "0");
         Test_Render (Test, Format, "", 1, "1st");
         Test_Render (Test, Format, "", 4, "4th");
         Test_Render (Test, Format, "", 10, "10th");
      end;

      Test_Render (Test, Ordinal, -1, "-1?");
      Test_Render (Test, Ordinal, 0, "0");
      Test_Render (Test, Ordinal, 1, "1st");
      Test_Render (Test, Ordinal, 2, "2nd");
      Test_Render (Test, Ordinal, 3, "3rd");
      Test_Render (Test, Ordinal, 4, "4th");

      Test_Render (Test, "(prefix (a) (b invalid (9 5)))", 0, "0");
      Test_Render (Test, "(prefix (c (invalid 5) (-1 invalid)))", 0, "0");
      Test_Render (Test, "(prefix (d ((invalid) 5) (-1)) ())", 0, "0");

      declare
         Format : Templates.Integers.Format;
      begin
         Format.Set_Minimum_Width (10);
         Format.Set_Suffix (1, To_Atom ("er"), 2);
         Format.Set_Prefix (10, To_Atom ("dix : "));

         Test_Render (Test, Format, "", 5, "         5");
         Test_Render (Test, Format, "", 1, "       1er");
         Test_Render (Test, Format, "(centered)", 10, " dix : 10 ");
         Test_Render (Test, Format, "(suffix ((th 0) 7))", 7, "         7th");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Prefix_And_Suffix;

   procedure Static_Hash_Map (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Parse errors in template");
   begin
      if not Natools.Static_Maps.S_Expressions.Templates.Integers.T then
         Test.Fail;
      end if;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Static_Hash_Map;

end Natools.S_Expressions.Templates.Tests.Integers;

add tests for prefix and suffix width

s_expressions-templates-tests-integers: add tests for prefix and suffix width


-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  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.
-----------------------------------------------------------------------

package body Util.Dates is

   --  ------------------------------
   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   --  ------------------------------
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0) is
   begin
      Into.Date      := Date;
      Into.Time_Zone := Time_Zone;
      Ada.Calendar.Formatting.Split (Date        => Date,
                                     Year        => Into.Year,
                                     Month       => Into.Month,
                                     Day         => Into.Month_Day,
                                     Hour        => Into.Hour,
                                     Minute      => Into.Minute,
                                     Second      => Into.Second,
                                     Sub_Second  => Into.Sub_Second,
                                     Leap_Second => Into.Leap_Second,
                                     Time_Zone   => Time_Zone);
      Into.Day := Ada.Calendar.Formatting.Day_Of_Week (Date);
   end Split;

end Util.Dates;

-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  Copyright (C) 2011, 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 Ada.Calendar.Arithmetic;
package body Util.Dates is

   --  ------------------------------
   --  Split the date into a date record (See Ada.Calendar.Formatting.Split).
   --  ------------------------------
   procedure Split (Into       : out Date_Record;
                    Date       : in Ada.Calendar.Time;
                    Time_Zone  : in Ada.Calendar.Time_Zones.Time_Offset := 0) is
   begin
      Into.Date      := Date;
      Into.Time_Zone := Time_Zone;
      Ada.Calendar.Formatting.Split (Date        => Date,
                                     Year        => Into.Year,
                                     Month       => Into.Month,
                                     Day         => Into.Month_Day,
                                     Hour        => Into.Hour,
                                     Minute      => Into.Minute,
                                     Second      => Into.Second,
                                     Sub_Second  => Into.Sub_Second,
                                     Leap_Second => Into.Leap_Second,
                                     Time_Zone   => Time_Zone);
      Into.Day := Ada.Calendar.Formatting.Day_Of_Week (Date);
   end Split;

   --  ------------------------------
   --  Get a time representing the given date at 00:00:00.
   --  ------------------------------
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time is
   begin
      return Ada.Calendar.Formatting.Time_Of (Year        => Date.Year,
                                              Month       => Date.Month,
                                              Day         => Date.Month_Day,
                                              Hour        => 0,
                                              Minute      => 0,
                                              Second      => 0,
                                              Sub_Second  => 0.0,
                                              Time_Zone   => Date.Time_Zone);
   end Get_Day_Start;

   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time is
      D : Date_Record;
   begin
      Split (D, Date);
      return Get_Day_Start (D);
   end Get_Day_Start;

   --  ------------------------------
   --  Get a time representing the beginning of the week at 00:00:00.
   --  ------------------------------
   function Get_Week_Start (Date : in Date_Record) return Ada.Calendar.Time is
      use Ada.Calendar.Formatting;
      use Ada.Calendar.Arithmetic;

      T : constant Ada.Calendar.Time := Time_Of (Year        => Date.Year,
                                                 Month       => Date.Month,
                                                 Day         => Date.Month_Day,
                                                 Hour        => 0,
                                                 Minute      => 0,
                                                 Second      => 0,
                                                 Sub_Second  => 0.0,
                                                 Time_Zone   => Date.Time_Zone);
      Day : constant Ada.Calendar.Formatting.Day_Name := Ada.Calendar.Formatting.Day_Of_Week (T);
   begin
      if Day = Ada.Calendar.Formatting.Monday then
         return T;
      else
         return T - Day_Count (Day_Name'Pos (Day) - Day_Name'Pos (Monday));
      end if;
   end Get_Week_Start;

   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time is
      D : Date_Record;
   begin
      Split (D, Date);
      return Get_Week_Start (D);
   end Get_Week_Start;

   --  ------------------------------
   --  Get a time representing the beginning of the month at 00:00:00.
   --  ------------------------------
   function Get_Month_Start (Date : in Date_Record) return Ada.Calendar.Time is
   begin
      return Ada.Calendar.Formatting.Time_Of (Year        => Date.Year,
                                              Month       => Date.Month,
                                              Day         => Ada.Calendar.Day_Number'First,
                                              Hour        => 0,
                                              Minute      => 0,
                                              Second      => 0,
                                              Sub_Second  => 0.0,
                                              Time_Zone   => Date.Time_Zone);
   end Get_Month_Start;

   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time is
      D : Date_Record;
   begin
      Split (D, Date);
      return Get_Month_Start (D);
   end Get_Month_Start;

end Util.Dates;

Implement the new functions Get_Day_Start, Get_Week_Start and Get_Month_Start


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

with MAT.Frames;
with MAT.Events.Probes;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   Not_Found : exception;

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural := 0;
      Total_Alloc   : MAT.Types.Target_Size := 0;
      Total_Free    : MAT.Types.Target_Size := 0;
      Malloc_Count  : Natural := 0;
      Free_Count    : Natural := 0;
      Realloc_Count : Natural := 0;
      Used_Count    : Natural := 0;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class);

   --  Add the memory region from the list of memory region managed by the program.
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info);

   --  Find the memory region that intersect the given section described by <tt>From</tt>
   --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
   --  map.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Region_Info_Map);

   --  Find the region that matches the given name.
   function Find_Region (Memory : in Target_Memory;
                         Name   : in String) return Region_Info;

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation;
                         Size   : out MAT.Types.Target_Size;
                         By     : out MAT.Events.Event_Id_Type);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation;
                            Old_Size : out MAT.Types.Target_Size;
                            By       : out MAT.Events.Event_Id_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Get the global memory and allocation statistics.
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Add the memory region from the list of memory region managed by the program.
      procedure Add_Region (Region : in Region_Info);

      --  Find the region that matches the given name.
      function Find_Region (Name   : in String) return Region_Info;

      --  Find the memory region that intersect the given section described by <tt>From</tt>
      --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
      --  map.
      procedure Find (From : in MAT.Types.Target_Addr;
                      To   : in MAT.Types.Target_Addr;
                      Into : in out MAT.Memory.Region_Info_Map);

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation;
                            Size   : out MAT.Types.Target_Size;
                            By     : out MAT.Events.Event_Id_Type);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation;
                               Old_Size : out MAT.Types.Target_Size;
                               By       : out MAT.Events.Event_Id_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

      --  Get the global memory and allocation statistics.
      procedure Stat_Information (Result : out Memory_Stat);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Regions       : Region_Info_Map;
      Stats         : Memory_Stat;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Manager       : MAT.Events.Probes.Probe_Manager_Type_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory clients - Client info related to its memory
--  Copyright (C) 2014, 2015, 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 MAT.Events.Probes;
with MAT.Memory.Tools;
with MAT.Expressions;
package MAT.Memory.Targets is

   Not_Found : exception;

   --  Define some global statistics about the memory slots.
   type Memory_Stat is record
      Thread_Count  : Natural := 0;
      Total_Alloc   : MAT.Types.Target_Size := 0;
      Total_Free    : MAT.Types.Target_Size := 0;
      Malloc_Count  : Natural := 0;
      Free_Count    : Natural := 0;
      Realloc_Count : Natural := 0;
      Used_Count    : Natural := 0;
   end record;

   type Target_Memory is tagged limited private;
   type Client_Memory_Ref is access all Target_Memory;

   --  Initialize the target memory object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory events.
   procedure Initialize (Memory  : in out Target_Memory;
                         Manager : in out MAT.Events.Probes.Probe_Manager_Type'Class);

   --  Add the memory region from the list of memory region managed by the program.
   procedure Add_Region (Memory : in out Target_Memory;
                         Region : in Region_Info);

   --  Find the memory region that intersect the given section described by <tt>From</tt>
   --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
   --  map.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Into   : in out MAT.Memory.Region_Info_Map);

   --  Find the region that matches the given name.
   function Find_Region (Memory : in Target_Memory;
                         Name   : in String) return Region_Info;

   --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
   --  in the used slots map.  The freed slots that intersect the malloc'ed region are
   --  removed from the freed map.
   procedure Probe_Malloc (Memory : in out Target_Memory;
                           Addr   : in MAT.Types.Target_Addr;
                           Slot   : in Allocation);

   --  Take into account a free probe.  Add the memory slot in the freed map and remove
   --  the slot from the used slots map.
   procedure Probe_Free (Memory : in out Target_Memory;
                         Addr   : in MAT.Types.Target_Addr;
                         Slot   : in Allocation;
                         Size   : out MAT.Types.Target_Size;
                         By     : out MAT.Events.Event_Id_Type);

   --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
   --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
   --  inserted in the used slots map.
   procedure Probe_Realloc (Memory   : in out Target_Memory;
                            Addr     : in MAT.Types.Target_Addr;
                            Old_Addr : in MAT.Types.Target_Addr;
                            Slot     : in Allocation;
                            Old_Size : out MAT.Types.Target_Size;
                            By       : out MAT.Events.Event_Id_Type);

   --  Collect the information about memory slot sizes allocated by the application.
   procedure Size_Information (Memory : in out Target_Memory;
                               Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

   --  Collect the information about threads and the memory allocations they've made.
   procedure Thread_Information (Memory  : in out Target_Memory;
                                 Threads : in out Memory_Info_Map);

   --  Collect the information about frames and the memory allocations they've made.
   procedure Frame_Information (Memory : in out Target_Memory;
                                Level  : in Natural;
                                Frames : in out Frame_Info_Map);

   --  Get the global memory and allocation statistics.
   procedure Stat_Information (Memory : in out Target_Memory;
                               Result : out Memory_Stat);

   --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
   --  the region [From .. To] and which is selected by the given filter expression.
   --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
   --  the memory slot.
   procedure Find (Memory : in out Target_Memory;
                   From   : in MAT.Types.Target_Addr;
                   To     : in MAT.Types.Target_Addr;
                   Filter : in MAT.Expressions.Expression_Type;
                   Into   : in out MAT.Memory.Allocation_Map);

private

   protected type Memory_Allocator is

      --  Add the memory region from the list of memory region managed by the program.
      procedure Add_Region (Region : in Region_Info);

      --  Find the region that matches the given name.
      function Find_Region (Name   : in String) return Region_Info;

      --  Find the memory region that intersect the given section described by <tt>From</tt>
      --  and <tt>To</tt>.  Each memory region that intersects is added to the <tt>Into</tt>
      --  map.
      procedure Find (From : in MAT.Types.Target_Addr;
                      To   : in MAT.Types.Target_Addr;
                      Into : in out MAT.Memory.Region_Info_Map);

      --  Take into account a malloc probe.  The memory slot [Addr .. Slot.Size] is inserted
      --  in the used slots map.  The freed slots that intersect the malloc'ed region are
      --  removed from the freed map.
      procedure Probe_Malloc (Addr   : in MAT.Types.Target_Addr;
                              Slot   : in Allocation);

      --  Take into account a free probe.  Add the memory slot in the freed map and remove
      --  the slot from the used slots map.
      procedure Probe_Free (Addr   : in MAT.Types.Target_Addr;
                            Slot   : in Allocation;
                            Size   : out MAT.Types.Target_Size;
                            By     : out MAT.Events.Event_Id_Type);

      --  Take into account a realloc probe.  The old memory slot represented by Old_Addr is
      --  removed from the used slots maps and the new memory slot [Addr .. Slot.Size] is
      --  inserted in the used slots map.
      procedure Probe_Realloc (Addr     : in MAT.Types.Target_Addr;
                               Old_Addr : in MAT.Types.Target_Addr;
                               Slot     : in Allocation;
                               Old_Size : out MAT.Types.Target_Size;
                               By       : out MAT.Events.Event_Id_Type);

      --  Collect the information about memory slot sizes allocated by the application.
      procedure Size_Information (Sizes  : in out MAT.Memory.Tools.Size_Info_Map);

      --  Collect the information about threads and the memory allocations they've made.
      procedure Thread_Information (Threads : in out Memory_Info_Map);

      --  Collect the information about frames and the memory allocations they've made.
      procedure Frame_Information (Level  : in Natural;
                                   Frames : in out Frame_Info_Map);

      --  Find from the <tt>Memory</tt> map the memory slots whose address intersects
      --  the region [From .. To] and which is selected by the given filter expression.
      --  Add the memory slot in the <tt>Into</tt> list if it does not already contains
      --  the memory slot.
      procedure Find (From   : in MAT.Types.Target_Addr;
                      To     : in MAT.Types.Target_Addr;
                      Filter : in MAT.Expressions.Expression_Type;
                      Into   : in out MAT.Memory.Allocation_Map);

      --  Get the global memory and allocation statistics.
      procedure Stat_Information (Result : out Memory_Stat);

   private
      Used_Slots    : Allocation_Map;
      Freed_Slots   : Allocation_Map;
      Regions       : Region_Info_Map;
      Stats         : Memory_Stat;
   end Memory_Allocator;

   type Target_Memory is tagged limited record
      Manager       : MAT.Events.Probes.Probe_Manager_Type_Access;
      Memory        : Memory_Allocator;
   end record;

end MAT.Memory.Targets;

Fix compilation warning with GNAT 2018

Fix compilation warning with GNAT 2018