-----------------------------------------------------------------------
--  util-http-clients-web -- HTTP Clients with AWS implementation
--  Copyright (C) 2011, 2012, 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 AWS.Headers.Set;
with AWS.Messages;
with Util.Log.Loggers;
package body Util.Http.Clients.Web is

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Web");

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   overriding
   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Get {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Get;

   overriding
   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Post {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data,
                                         Headers => Req.Headers,
                                         Timeouts => Req.Timeouts);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Put {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Put (URL => URI, Data => Data, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Put;

   overriding
   procedure Do_Delete (Manager  : in AWS_Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Delete {0}", URI);

      Reply.Delegate := Rep.all'Access;
      --  Rep.Data       := AWS.Client.Delete (URL => URI, Data => "", Headers => Req.Headers,
      --                                       Timeouts => Req.Timeouts);
      raise Program_Error with "Delete is not supported by AWS and there is no easy conditional"
        & " compilation in Ada to enable Delete support for the latest AWS version. "
        & "For now, you have to use curl, or install the latest AWS version and then "
        & "uncomment the AWS.Client.Delete call and remove this exception.";
   end Do_Delete;

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   overriding
   procedure Set_Timeout (Manager : in AWS_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is
   begin
      AWS_Http_Request'Class (Http.Delegate.all).Timeouts
         := AWS.Client.Timeouts (Connect  => Timeout,
                                 Send     => Timeout,
                                 Receive  => Timeout,
                                 Response => Timeout);
   end Set_Timeout;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
   begin
      raise Program_Error with "Contains_Header is not implemented";
      return False;
   end Contains_Header;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
   begin
      return "";
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Set.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

-----------------------------------------------------------------------
--  util-http-clients-web -- HTTP Clients with AWS implementation
--  Copyright (C) 2011, 2012, 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.Strings.Unbounded;
with AWS.Messages;
with Util.Log.Loggers;
package body Util.Http.Clients.Web is

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Web");

   Manager : aliased AWS_Http_Manager;

   --  ------------------------------
   --  Register the Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural;

   function To_Status (Code : in AWS.Messages.Status_Code) return Natural is
      use AWS.Messages;
   begin
      case Code is
         when S100 =>
            return 100;
         when S101 =>
            return 101;
         when S102 =>
            return 102;
         when S200 =>
            return 200;
         when S201 =>
            return 201;
         when S203 =>
            return 203;
         when S204 =>
            return 204;
         when S205 =>
            return 205;
         when S206 =>
            return 206;
         when S207 =>
            return 207;
         when S300 =>
            return 300;
         when S301 =>
            return 301;
         when S302 =>
            return 302;
         when S303 =>
            return 303;
         when S304 =>
            return 304;
         when S305 =>
            return 305;
         when S307 =>
            return 307;
         when S400 =>
            return 400;
         when S401 =>
            return 401;
         when S402 =>
            return 402;
         when S403 =>
            return 403;
         when S404 =>
            return 404;
         when S405 =>
            return 405;
         when S406 =>
            return 406;
         when S407 =>
            return 407;
         when S408 =>
            return 408;
         when S409 =>
            return 409;
         when S410 =>
            return 410;
         when S411 =>
            return 411;
         when S412 =>
            return 412;
         when S413 =>
            return 413;
         when S414 =>
            return 414;
         when S415 =>
            return 415;
         when S416 =>
            return 416;
         when S417 =>
            return 417;
         when S422 =>
            return 422;
         when S423 =>
            return 423;
         when S424 =>
            return 424;
         when S500 =>
            return 500;
         when S501 =>
            return 501;
         when S502 =>
            return 502;
         when S503 =>
            return 503;
         when S504 =>
            return 504;
         when S505 =>
            return 505;
         when S507 =>
            return 507;
         when others =>
            return 500;
      end case;
   end To_Status;

   procedure Create (Manager  : in AWS_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);
   begin
      Http.Delegate := new AWS_Http_Request;
   end Create;

   overriding
   procedure Do_Get (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Get {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Get (URL => URI, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Get;

   overriding
   procedure Do_Post (Manager  : in AWS_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Post {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Post (URL => URI, Data => Data,
                                         Headers => Req.Headers,
                                         Timeouts => Req.Timeouts);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in AWS_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);

      Req     : constant AWS_Http_Request_Access
        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Put {0}", URI);

      Reply.Delegate := Rep.all'Access;
      Rep.Data       := AWS.Client.Put (URL => URI, Data => Data, Headers => Req.Headers,
                                        Timeouts => Req.Timeouts);
   end Do_Put;

   overriding
   procedure Do_Delete (Manager  : in AWS_Http_Manager;
                        Http     : in Client'Class;
                        URI      : in String;
                        Reply    : out Response'Class) is
      pragma Unreferenced (Manager, Http);

--      Req     : constant AWS_Http_Request_Access
--        := AWS_Http_Request'Class (Http.Delegate.all)'Access;
      Rep     : constant AWS_Http_Response_Access := new AWS_Http_Response;
   begin
      Log.Info ("Delete {0}", URI);

      Reply.Delegate := Rep.all'Access;
      --  Rep.Data       := AWS.Client.Delete (URL => URI, Data => "", Headers => Req.Headers,
      --                                       Timeouts => Req.Timeouts);
      raise Program_Error with "Delete is not supported by AWS and there is no easy conditional"
        & " compilation in Ada to enable Delete support for the latest AWS version. "
        & "For now, you have to use curl, or install the latest AWS version and then "
        & "uncomment the AWS.Client.Delete call and remove this exception.";
   end Do_Delete;

   --  ------------------------------
   --  Set the timeout for the connection.
   --  ------------------------------
   overriding
   procedure Set_Timeout (Manager : in AWS_Http_Manager;
                          Http    : in Client'Class;
                          Timeout : in Duration) is
      pragma Unreferenced (Manager);
   begin
      AWS_Http_Request'Class (Http.Delegate.all).Timeouts
         := AWS.Client.Timeouts (Connect  => Timeout,
                                 Send     => Timeout,
                                 Receive  => Timeout,
                                 Response => Timeout);
   end Set_Timeout;

   --  ------------------------------
   --  Returns a boolean indicating whether the named request header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Http : in AWS_Http_Request;
                             Name : in String) return Boolean is
      Values : constant AWS.Headers.VString_Array
        := AWS.Headers.Get_Values (Http.Headers, Name);
   begin
      return Values'Length > 0;
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   overriding
   function Get_Header (Request : in AWS_Http_Request;
                        Name    : in String) return String is
      Values : constant AWS.Headers.VString_Array
        := AWS.Headers.Get_Values (Request.Headers, Name);
   begin
      if Values'Length > 0 then
         return Ada.Strings.Unbounded.To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Sets a request header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   --  ------------------------------
   overriding
   procedure Set_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Add (Http.Headers, Name, Value);
   end Set_Header;

   --  ------------------------------
   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   --  ------------------------------
   overriding
   procedure Add_Header (Http  : in out AWS_Http_Request;
                         Name  : in String;
                         Value : in String) is
   begin
      AWS.Headers.Add (Http.Headers, Name, Value);
   end Add_Header;

   --  Iterate over the request headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Request : in AWS_Http_Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Returns a boolean indicating whether the named response header has already
   --  been set.
   --  ------------------------------
   function Contains_Header (Reply : in AWS_Http_Response;
                             Name  : in String) return Boolean is
   begin
      return AWS.Response.Header (Reply.Data, Name) /= "";
   end Contains_Header;

   --  ------------------------------
   --  Returns the value of the specified response header as a String. If the response
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any response header.
   --  ------------------------------
   function Get_Header (Reply  : in AWS_Http_Response;
                        Name   : in String) return String is
   begin
      return AWS.Response.Header (Reply.Data, Name);
   end Get_Header;

   --  Sets a message header with the given name and value. If the header had already
   --  been set, the new value overwrites the previous one. The containsHeader
   --  method can be used to test for the presence of a header before setting its value.
   overriding
   procedure Set_Header (Reply    : in out AWS_Http_Response;
                         Name     : in String;
                         Value    : in String) is
   begin
      null;
   end Set_Header;

   --  Adds a request header with the given name and value.
   --  This method allows request headers to have multiple values.
   overriding
   procedure Add_Header (Reply   : in out AWS_Http_Response;
                         Name    : in String;
                         Value   : in String) is
   begin
      null;
   end Add_Header;

   --  Iterate over the response headers and executes the Process procedure.
   overriding
   procedure Iterate_Headers (Reply   : in AWS_Http_Response;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      null;
   end Iterate_Headers;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   function Get_Body (Reply : in AWS_Http_Response) return String is
   begin
      return AWS.Response.Message_Body (Reply.Data);
   end Get_Body;

   --  Get the response status code.
   overriding
   function Get_Status (Reply : in AWS_Http_Response) return Natural is
   begin
      return To_Status (AWS.Response.Status_Code (Reply.Data));
   end Get_Status;

end Util.Http.Clients.Web;

Implement Contains_Header and Get_Header Avoid using the deprecated AWS.Headers.Set package


-----------------------------------------------------------------------
--  awa-awa-settings-modules -- Module awa-settings
--  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.Unchecked_Deallocation;

with AWA.Services.Contexts;
with AWA.Modules.Get;
with Util.Log.Loggers;
package body AWA.Settings.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Awa-settings.Module");

   package ASC renames AWA.Services.Contexts;

   --  Set the user setting with the given name in the setting manager cache
   --  and in the database.
   procedure Set (Manager : in out Setting_Manager;
                  Name    : in String;
                  Value   : in String) is
   begin
      Manager.Data.Set (Name, Value);
   end Set;

   --  Get the user setting with the given name from the setting manager cache.
   --  Load the user setting from the database if necessary.
   procedure Get (Manager : in out Setting_Manager;
                  Name    : in String;
                  Default : in String;
                  Value   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Manager.Data.Get (Name, Default, Value);
   end Get;

   function Current return Setting_Manager_Access is
      Ctx : ASC.Service_Context_Access := ASC.Current;
   begin
--        Settings := Ctx.Get_Session_Attribute ("AWA.Settings");
--        if Settings = null then
--           --  create
--           null;
--        end if;
      return null;
   end Current;

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

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

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the awa-settings module.
   --  ------------------------------
   function Get_Setting_Module return Setting_Module_Access is
      function Get is new AWA.Modules.Get (Setting_Module, Setting_Module_Access, NAME);
   begin
      return Get;
   end Get_Setting_Module;

   procedure Free is new Ada.Unchecked_Deallocation (Object => Setting_Data,
                                                     Name   => Setting_Data_Access);

   use Ada.Strings.Unbounded;

   protected body Settings is

      procedure Get (Name    : in String;
                     Default : in String;
                     Value   : out Ada.Strings.Unbounded.Unbounded_String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               Value := Item.Value;
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Value := Ada.Strings.Unbounded.To_Unbounded_String (Default);
      end Get;

      procedure Set (Name  : in String;
                     Value : in String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               if Item.Value = Value then
                  return;
               end if;
               Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
      end Set;

      procedure Clear is
      begin
         while First /= null loop
            declare
               Item : Setting_Data_Access := First;
            begin
               First := Item.Next_Setting;
               Free (Item);
            end;
         end loop;
      end Clear;

   end Settings;

end AWA.Settings.Modules;

-----------------------------------------------------------------------
--  awa-awa-settings-modules -- Module awa-settings
--  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.Unchecked_Deallocation;

with AWA.Services.Contexts;
with AWA.Modules.Get;
with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Beans.Basic;
package body AWA.Settings.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Awa-settings.Module");

   package ASC renames AWA.Services.Contexts;

   --  Set the user setting with the given name in the setting manager cache
   --  and in the database.
   procedure Set (Manager : in out Setting_Manager;
                  Name    : in String;
                  Value   : in String) is
   begin
      Manager.Data.Set (Name, Value);
   end Set;

   --  Get the user setting with the given name from the setting manager cache.
   --  Load the user setting from the database if necessary.
   procedure Get (Manager : in out Setting_Manager;
                  Name    : in String;
                  Default : in String;
                  Value   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Manager.Data.Get (Name, Default, Value);
   end Get;

   function Current return Setting_Manager_Access is
      Ctx : ASC.Service_Context_Access := ASC.Current;
      Obj : Util.Beans.Objects.Object := Ctx.Get_Session_Attribute ("AWA.Settings");
      Bean : access Util.Beans.Basic.Readonly_Bean'Class := Util.Beans.Objects.To_Bean (Obj);
   begin
      if Bean = null or else not (Bean.all in Setting_Manager'Class) then
         declare
            Mgr : Setting_Manager_Access := new Setting_Manager;
         begin
            Obj := Util.Beans.Objects.To_Object (Mgr.all'Access);
            Ctx.Set_Session_Attribute ("AWA.Settings", Obj);
            return Mgr;
         end;
      else
         return Setting_Manager'Class (Bean.all)'Access;
      end if;
   end Current;

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

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

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the awa-settings module.
   --  ------------------------------
   function Get_Setting_Module return Setting_Module_Access is
      function Get is new AWA.Modules.Get (Setting_Module, Setting_Module_Access, NAME);
   begin
      return Get;
   end Get_Setting_Module;

   procedure Free is new Ada.Unchecked_Deallocation (Object => Setting_Data,
                                                     Name   => Setting_Data_Access);

   use Ada.Strings.Unbounded;

   protected body Settings is

      procedure Get (Name    : in String;
                     Default : in String;
                     Value   : out Ada.Strings.Unbounded.Unbounded_String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               Value := Item.Value;
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Value := Ada.Strings.Unbounded.To_Unbounded_String (Default);
      end Get;

      procedure Set (Name  : in String;
                     Value : in String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               if Item.Value = Value then
                  return;
               end if;
               Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
      end Set;

      procedure Clear is
      begin
         while First /= null loop
            declare
               Item : Setting_Data_Access := First;
            begin
               First := Item.Next_Setting;
               Free (Item);
            end;
         end loop;
      end Clear;

   end Settings;

end AWA.Settings.Modules;

Create the setting manager if there is none and save it in the HTTP session


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

package Babel.Base is

end Babel.Base;

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

package Babel.Base is

   type Database is abstract new Ada.Finalization.Limited_Controlled with private;

private

   type Database is abstract new Ada.Finalization.Limited_Controlled with record
      Name : Integer;
   end record;

end Babel.Base;

Define the abstract Database type to represent the database of backup files


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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER);

   type Notice_Type is (N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER,
                       F_ID,
                       F_OLD_ADDR,
                       F_TIME,
                       F_EVENT);

   type Notice_Type is (N_PID_INFO,
                        N_DURATION,
                        N_PATH_INFO);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the time tick as a duration and print it for the given field.
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

Declare the Print_Duration operation to format a time


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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

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

with MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_TOTAL_SIZE,
                       F_MIN_SIZE,
                       F_MAX_SIZE,
                       F_MIN_ADDR,
                       F_MAX_ADDR,
                       F_THREAD,
                       F_COUNT,
                       F_FILE_NAME,
                       F_FUNCTION_NAME,
                       F_LINE_NUMBER);

   type Console_Type is abstract tagged limited private;
   type Console_Access is access all Console_Type'Class;

   --  Report an error message.
   procedure Error (Console : in out Console_Type;
                    Message : in String) is abstract;

   -- Report a notice message.
   procedure Notice (Console : in out Console_Type;
                     Message : in String) is abstract;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Start a new title in a report.
   procedure Start_Title (Console : in out Console_Type) is abstract;

   --  Finish a new title in a report.
   procedure End_Title (Console : in out Console_Type) is abstract;

   --  Start a new row in a report.
   procedure Start_Row (Console : in out Console_Type) is abstract;

   --  Finish a new row in a report.
   procedure End_Row (Console : in out Console_Type) is abstract;

   --  Print the title for the given field and setup the associated field size.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive);

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

   --  Format the thread information and print it for the given field.
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer);

   --  Format the integer and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String);

private

   type Field_Size_Array is array (Field_Type) of Natural;

   type Field_List_Array is array (1 .. Field_Type'Pos (Field_Type'Last)) of Field_Type;

   type Console_Type is abstract tagged limited record
      Sizes       : Field_Size_Array := (others => 1);
      Cols        : Field_Size_Array := (others => 1);
      Fields      : Field_List_Array;
      Field_Count : Natural := 0;
   end record;

end MAT.Consoles;

Declare the Notice procedure to report some information message


with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Opentoken.Recognizer.Character_Set;
with Opentoken.Recognizer.Identifier;
with Opentoken.Recognizer.Integer;
with Opentoken.Recognizer.Keyword;
with Opentoken.Recognizer.Line_Comment;
with Opentoken.Recognizer.Separator;
with Opentoken.Recognizer.Single_Character_Set;
with Opentoken.Recognizer.String;
with OpenToken.Text_Feeder.String;
with Opentoken.Token.Enumerated.Analyzer;

package body Reader is

   type Lexemes is (Int, Sym,
                    Nil, True_Tok, False_Tok, Exp_Tok,
                    Str, Atom,
                    Whitespace, Comment);

   package Lisp_Tokens is new Opentoken.Token.Enumerated (Lexemes);
   package Tokenizer is new Lisp_Tokens.Analyzer;

   Exp_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("**"));

   Nil_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("nil"));

   True_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("true"));

   False_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("false"));

   ID_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Identifier.Get);

   Int_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Integer.Get);

   String_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.String.Get);

   -- Atom definition
   Start_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.Constants.Letter_Set;

   Body_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Alphanumeric_Set,
        Ada.Strings.Maps.To_Set ('-'));

   Atom_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.Identifier.Get (Start_Chars, Body_Chars));

   Lisp_Syms : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set ("[]{}()'`~^@+-*/");

   Sym_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Single_Character_Set.Get (Lisp_Syms));

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set (Ada.Characters.Latin_1.HT &
                              Ada.Characters.Latin_1.Space &
                              Ada.Characters.Latin_1.Comma);

   Whitesp_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Character_Set.Get (Lisp_Whitespace));

   Comment_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Line_Comment.Get (";"));

   Syntax : constant Tokenizer.Syntax :=
     (Int           => Int_Recognizer,
      Sym => Sym_Recognizer,
      Nil           => Nil_Recognizer,
      True_Tok      => True_Recognizer,
      False_Tok     => False_Recognizer,
      Exp_Tok       => Exp_Recognizer,
      Str           => String_Recognizer,
      Atom          => Atom_Recognizer,
      Whitespace    => Whitesp_Recognizer,
      Comment       => Comment_Recognizer  --,
     );

   Input_Feeder : aliased OpenToken.Text_Feeder.String.Instance;

   Analyzer : Tokenizer.Instance :=
     Tokenizer.Initialize (Syntax, Input_Feeder'access);

   function Get_Token_String return String is
   begin
      return Tokenizer.Lexeme (Analyzer);
   end Get_Token_String;

   function Get_Token_Char return Character is
      S : String := Tokenizer.Lexeme (Analyzer);
   begin
      return S(S'First);
   end Get_Token_Char;

   function Get_Token return Types.Mal_Type_Access is
      Res : Types.Mal_Type_Access;
   begin
      Tokenizer.Find_Next (Analyzer);
      case Tokenizer.ID (Analyzer) is
         when Int =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Int,
               Int_Val => Integer'Value (Get_Token_String));
         when Sym =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Sym, Symbol => Get_Token_Char);
         when Nil =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when True_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when False_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Exp_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Str =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Str,
               The_String => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Atom =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Whitespace | Comment => null;
      end case;
      return Res;
   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Type_Access;

   function Read_List return Types.Mal_Type_Access is
      use types;
      List_MT, MTA : Types.Mal_Type_Access;
   begin
      List_MT := new Types.Mal_Type'
                       (Sym_Type => Types.List,
                        The_List => Types.Lists.Empty_List);
      loop
         MTA := Read_Form;
         exit when MTA = null or else
                   MTA.all = (Sym_Type => Sym, Symbol => ')');
         Types.Lists.Append (List_MT.The_List, MTA);
      end loop;
      return List_MT;
   end Read_List;

   function Read_Form return Types.Mal_Type_Access is
      use Types;
      MT : Types.Mal_Type_Access;
   begin
      MT := Get_Token;
      if MT.all = (Sym_Type => Sym, Symbol => '(') then
         return Read_List;
      else
         return MT;
      end if;
   end Read_Form;

   function Read_Str (S : String) return Types.Mal_Type_Access is
   begin
      Analyzer.Reset;
      Input_Feeder.Set (S);
      return Read_Form;
   exception
      when OPENTOKEN.SYNTAX_ERROR =>
         Ada.Text_IO.Put_Line
           (Ada.Text_IO.Standard_Error,
            "Lexical error at char " & Integer'Image (Analyzer.Line));
         raise Ada.IO_Exceptions.End_Error;
   end Read_Str;

end Reader;

with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Opentoken.Recognizer.Character_Set;
with Opentoken.Recognizer.Identifier;
with Opentoken.Recognizer.Integer;
with Opentoken.Recognizer.Keyword;
with Opentoken.Recognizer.Line_Comment;
with Opentoken.Recognizer.Separator;
with Opentoken.Recognizer.Single_Character_Set;
with Opentoken.Recognizer.String;
with OpenToken.Text_Feeder.String;
with Opentoken.Token.Enumerated.Analyzer;

package body Reader is

   type Lexemes is (Int, Sym,
                    Nil, True_Tok, False_Tok, Exp_Tok,
                    Str, Atom,
                    Whitespace, Comment);

   package Lisp_Tokens is new Opentoken.Token.Enumerated (Lexemes);
   package Tokenizer is new Lisp_Tokens.Analyzer;

   Exp_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Separator.Get ("**"));

   Nil_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("nil"));

   True_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Keyword.Get ("true"));

   False_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Keyword.Get ("false"));

   ID_Recognizer   : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Identifier.Get);

   Int_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Integer.Get);

   -- Use the C style for escaped strings.
   String_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.String.Get
         (Escapeable => True,
          Double_Delimiter => False));

   -- Atom definition
   Start_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.Constants.Letter_Set;

   Body_Chars : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Ada.Strings.Maps.Constants.Alphanumeric_Set,
        Ada.Strings.Maps.To_Set ('-'));

   Atom_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get
       (Opentoken.Recognizer.Identifier.Get (Start_Chars, Body_Chars));

   Lisp_Syms : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set ("[]{}()'`~^@+-*/");

   Sym_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Single_Character_Set.Get (Lisp_Syms));

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set (Ada.Characters.Latin_1.HT &
                              Ada.Characters.Latin_1.Space &
                              Ada.Characters.Latin_1.Comma);

   Whitesp_Recognizer : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get (Opentoken.Recognizer.Character_Set.Get (Lisp_Whitespace));

   Comment_Recognizer  : constant Tokenizer.Recognizable_Token :=
     Tokenizer.Get(Opentoken.Recognizer.Line_Comment.Get (";"));

   Syntax : constant Tokenizer.Syntax :=
     (Int           => Int_Recognizer,
      Sym => Sym_Recognizer,
      Nil           => Nil_Recognizer,
      True_Tok      => True_Recognizer,
      False_Tok     => False_Recognizer,
      Exp_Tok       => Exp_Recognizer,
      Str           => String_Recognizer,
      Atom          => Atom_Recognizer,
      Whitespace    => Whitesp_Recognizer,
      Comment       => Comment_Recognizer  --,
     );

   Input_Feeder : aliased OpenToken.Text_Feeder.String.Instance;

   Analyzer : Tokenizer.Instance :=
     Tokenizer.Initialize (Syntax, Input_Feeder'access);

   function Get_Token_String return String is
   begin
      return Tokenizer.Lexeme (Analyzer);
   end Get_Token_String;

   function Get_Token_Char return Character is
      S : String := Tokenizer.Lexeme (Analyzer);
   begin
      return S(S'First);
   end Get_Token_Char;

   function Get_Token return Types.Mal_Type_Access is
      Res : Types.Mal_Type_Access;
   begin
      Tokenizer.Find_Next (Analyzer);
      case Tokenizer.ID (Analyzer) is
         when Int =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Int,
               Int_Val => Integer'Value (Get_Token_String));
         when Sym =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Sym, Symbol => Get_Token_Char);
         when Nil =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when True_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when False_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Exp_Tok =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Str =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Str,
               The_String => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Atom =>
            Res := new Types.Mal_Type'
              (Sym_Type => Types.Atom,
               The_Atom => Ada.Strings.Unbounded.To_Unbounded_String
                        (Get_Token_String));
         when Whitespace | Comment => null;
      end case;
      return Res;
   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Type_Access;

   function Read_List return Types.Mal_Type_Access is
      use types;
      List_MT, MTA : Types.Mal_Type_Access;
   begin
      List_MT := new Types.Mal_Type'
                       (Sym_Type => Types.List,
                        The_List => Types.Lists.Empty_List);
      loop
         MTA := Read_Form;
         exit when MTA = null or else
                   MTA.all = (Sym_Type => Sym, Symbol => ')');
         Types.Lists.Append (List_MT.The_List, MTA);
      end loop;
      return List_MT;
   end Read_List;

   function Read_Form return Types.Mal_Type_Access is
      use Types;
      MT : Types.Mal_Type_Access;
   begin
      MT := Get_Token;
      if MT.all = (Sym_Type => Sym, Symbol => '(') then
         return Read_List;
      else
         return MT;
      end if;
   end Read_Form;

   function Read_Str (S : String) return Types.Mal_Type_Access is
   begin
      Analyzer.Reset;
      Input_Feeder.Set (S);
      return Read_Form;
   exception
      when OPENTOKEN.SYNTAX_ERROR =>
         Ada.Text_IO.Put_Line
           (Ada.Text_IO.Standard_Error,
            "Lexical error at char " & Integer'Image (Analyzer.Line));
         raise Ada.IO_Exceptions.End_Error;
   end Read_Str;

end Reader;

Fix escapable strings

Ada: Fix escapable strings


-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  Copyright (C) 2011, 2013, 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.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;

--  = Date Utilities =
--  The `Util.Dates` package provides various date utilities to help in formatting and parsing
--  dates in various standard formats.  It completes the standard `Ada.Calendar.Formatting` and
--  other packages by implementing specific formatting and parsing.
--
--  == Date Operations ==
--  Several operations allow to compute from a given date:
--
--    * `Get_Day_Start`: The start of the day (0:00),
--    * `Get_Day_End`: The end of the day (23:59:59),
--    * `Get_Week_Start`: The start of the week,
--    * `Get_Week_End`: The end of the week,
--    * `Get_Month_Start`: The start of the month,
--    * `Get_Month_End`: The end of the month
--
--  The `Date_Record` type represents a date in a split format allowing
--  to access easily the day, month, hour and other information.
--
--    Now        : Ada.Calendar.Time := Ada.Calendar.Clock;
--    Week_Start : Ada.Calendar.Time := Get_Week_Start (Now);
--    Week_End   : Ada.Calendar.Time := Get_Week_End (Now);
--
--  @include util-dates-rfc7231.ads
--  @include util-dates-iso8601.ads
--  @include util-dates-formats.ads
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number := 1901;
      Month       : Ada.Calendar.Month_Number := 1;
      Month_Day   : Ada.Calendar.Day_Number := 1;
      Day         : Ada.Calendar.Formatting.Day_Name := Ada.Calendar.Formatting.Tuesday;
      Hour        : Ada.Calendar.Formatting.Hour_Number := 0;
      Minute      : Ada.Calendar.Formatting.Minute_Number := 0;
      Second      : Ada.Calendar.Formatting.Second_Number := 0;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration := 0.0;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset := 0;
      Leap_Second : Boolean := False;
   end record;

   --  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);

   --  Return the date from the date record (See Ada.Calendar.Formatting.Time_Of).
   function Time_Of (Date : in Date_Record) return Ada.Calendar.Time;

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  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;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  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;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

-----------------------------------------------------------------------
--  util-dates -- Date utilities
--  Copyright (C) 2011, 2013, 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.Calendar;
with Ada.Calendar.Formatting;
with Ada.Calendar.Arithmetic;
with Ada.Calendar.Time_Zones;

--  = Date Utilities =
--  The `Util.Dates` package provides various date utilities to help in formatting and parsing
--  dates in various standard formats.  It completes the standard `Ada.Calendar.Formatting` and
--  other packages by implementing specific formatting and parsing.
--
--  == Date Operations ==
--  Several operations allow to compute from a given date:
--
--    * `Get_Day_Start`: The start of the day (0:00),
--    * `Get_Day_End`: The end of the day (23:59:59),
--    * `Get_Week_Start`: The start of the week,
--    * `Get_Week_End`: The end of the week,
--    * `Get_Month_Start`: The start of the month,
--    * `Get_Month_End`: The end of the month
--
--  The `Date_Record` type represents a date in a split format allowing
--  to access easily the day, month, hour and other information.
--
--    Now        : Ada.Calendar.Time := Ada.Calendar.Clock;
--    Week_Start : Ada.Calendar.Time := Get_Week_Start (Now);
--    Week_End   : Ada.Calendar.Time := Get_Week_End (Now);
--
--  @include util-dates-rfc7231.ads
--  @include util-dates-iso8601.ads
--  @include util-dates-formats.ads
package Util.Dates is

   --  The Unix equivalent of 'struct tm'.
   type Date_Record is record
      Date        : Ada.Calendar.Time;
      Year        : Ada.Calendar.Year_Number := 1901;
      Month       : Ada.Calendar.Month_Number := 1;
      Month_Day   : Ada.Calendar.Day_Number := 1;
      Day         : Ada.Calendar.Formatting.Day_Name := Ada.Calendar.Formatting.Tuesday;
      Hour        : Ada.Calendar.Formatting.Hour_Number := 0;
      Minute      : Ada.Calendar.Formatting.Minute_Number := 0;
      Second      : Ada.Calendar.Formatting.Second_Number := 0;
      Sub_Second  : Ada.Calendar.Formatting.Second_Duration := 0.0;
      Time_Zone   : Ada.Calendar.Time_Zones.Time_Offset := 0;
      Leap_Second : Boolean := False;
   end record;

   --  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);

   --  Return the date from the date record (See Ada.Calendar.Formatting.Time_Of).
   function Time_Of (Date : in Date_Record) return Ada.Calendar.Time;

   --  Returns true if the given year is a leap year.
   function Is_Leap_Year (Year : in Ada.Calendar.Year_Number) return Boolean;

   --  Returns true if both dates are on the same day.
   function Is_Same_Day (Date1, Date2 : in Ada.Calendar.Time) return Boolean;
   function Is_Same_Day (Date1, Date2 : in Date_Record) return Boolean;

   --  Get the number of days in the given year.
   function Get_Day_Count (Year : in Ada.Calendar.Year_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get the number of days in the given month.
   function Get_Day_Count (Year  : in Ada.Calendar.Year_Number;
                           Month : in Ada.Calendar.Month_Number)
                           return Ada.Calendar.Arithmetic.Day_Count;

   --  Get a time representing the given date at 00:00:00.
   function Get_Day_Start (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the given date at 23:59:59.
   function Get_Day_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Day_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  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;
   function Get_Week_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the week at 23:59:99.
   function Get_Week_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Week_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  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;
   function Get_Month_Start (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

   --  Get a time representing the end of the month at 23:59:59.
   function Get_Month_End (Date : in Date_Record) return Ada.Calendar.Time;
   function Get_Month_End (Date : in Ada.Calendar.Time) return Ada.Calendar.Time;

end Util.Dates;

Declare the Is_Same_Day function to check if two times are on the same day


-----------------------------------------------------------------------
--  awa-permissions-beans -- Permission beans
--  Copyright (C) 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 ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Services.Contexts;
with AWA.Events.Action_Method;
with AWA.Permissions.Services;

package body AWA.Permissions.Beans is

   use Ada.Strings.Unbounded;

   package ASC renames AWA.Services.Contexts;

   package Create_Binding is
     new AWA.Events.Action_Method.Bind (Bean   => Permission_Bean,
                                        Method => Create,
                                        Name   => "create");

   Permission_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Permission_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_id" then
         From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_type" then
         From.Kind := Util.Beans.Objects.To_Unbounded_String (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Permission_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Permission_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a new permission.
   --  ------------------------------
   procedure Create (Bean    : in out Permission_Bean;
                     Event   : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Event);

      Ctx      : constant ASC.Service_Context_Access := ASC.Current;
      DB       : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Kind     : ADO.Entity_Type;
   begin
      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, To_String (Bean.Kind));
      AWA.Permissions.Services.Add_Permission (Session    => DB,
                                               Entity     => Bean.Get_Entity_Id,
                                               Kind       => Kind,
                                               User       => Ctx.Get_User_Identifier);
      Ctx.Commit;
   end Create;

   --  ------------------------------
   --  Create the permission bean instance.
   --  ------------------------------
   function Create_Permission_Bean return Util.Beans.Basic.Readonly_Bean_Access is
   begin
      return new Permission_Bean;
   end Create_Permission_Bean;

end AWA.Permissions.Beans;

-----------------------------------------------------------------------
--  awa-permissions-beans -- Permission beans
--  Copyright (C) 2015, 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 ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Services.Contexts;
with AWA.Events.Action_Method;
with AWA.Permissions.Services;

package body AWA.Permissions.Beans is

   use Ada.Strings.Unbounded;

   package ASC renames AWA.Services.Contexts;

   package Create_Binding is
     new AWA.Events.Action_Method.Bind (Bean   => Permission_Bean,
                                        Method => Create,
                                        Name   => "create");

   Permission_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Binding.Proxy'Access);

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Permission_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_id" then
         From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_type" then
         From.Kind := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "workspace_id" then
         From.Set_Workspace_Id (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Permission_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Permission_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a new permission.
   --  ------------------------------
   procedure Create (Bean    : in out Permission_Bean;
                     Event   : in AWA.Events.Module_Event'Class) is
      pragma Unreferenced (Event);

      Ctx      : constant ASC.Service_Context_Access := ASC.Current;
      DB       : ADO.Sessions.Master_Session := ASC.Get_Master_Session (Ctx);
      Kind     : ADO.Entity_Type;
   begin
      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, To_String (Bean.Kind));
      AWA.Permissions.Services.Add_Permission (Session    => DB,
                                               Entity     => Bean.Get_Entity_Id,
                                               Kind       => Kind,
                                               User       => Ctx.Get_User_Identifier,
                                               Workspace  => Bean.Get_Workspace_Id);
      Ctx.Commit;
   end Create;

   --  ------------------------------
   --  Create the permission bean instance.
   --  ------------------------------
   function Create_Permission_Bean return Util.Beans.Basic.Readonly_Bean_Access is
   begin
      return new Permission_Bean;
   end Create_Permission_Bean;

end AWA.Permissions.Beans;

Update the permission bean to add the workspace_id attribute and make the permission with it


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

with Ada.Finalization;
with Ada.Containers;
with Ada.Containers.Vectors;
with Util.Beans.Objects;

--  The Util.Beans.Basic.Lists generic package implements a list of
--  elements that can be accessed through the List_Bean interface.
generic
   type Element_Type is new Util.Beans.Basic.Readonly_Bean with private;
package Util.Beans.Basic.Lists is

   --  Package that represents the vectors of elements.
   --  (gcc 4.4 crashes if this package is defined as generic parameter.
   package Vectors is
     new Ada.Containers.Vectors (Element_Type => Element_Type,
                                 Index_Type   => Natural);

   --  The list of elements is defined in a public part so that applications
   --  can easily add or remove elements in the target list.  The List_Bean
   --  type holds the real implementation with the private parts.
   type Abstract_List_Bean is abstract new Ada.Finalization.Controlled
     and Util.Beans.Basic.List_Bean with record
      List : Vectors.Vector;
   end record;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The List_Bean type gives access to a list of objects.
   type List_Bean is new Abstract_List_Bean with private;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in List_Bean) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in List_Bean) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Initialize the list bean.
   overriding
   procedure Initialize (Object : in out List_Bean);

   --  Deletes the list bean
   procedure Free (List : in out Util.Beans.Basic.Readonly_Bean_Access);

private

   type List_Bean is new Abstract_List_Bean with record
      Current : aliased Element_Type;
      Row     : Util.Beans.Objects.Object;
   end record;

end Util.Beans.Basic.Lists;

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

with Ada.Finalization;
with Ada.Containers;
with Ada.Containers.Vectors;
with Util.Beans.Objects;

--  The Util.Beans.Basic.Lists generic package implements a list of
--  elements that can be accessed through the List_Bean interface.
generic
   type Element_Type is new Util.Beans.Basic.Readonly_Bean with private;
package Util.Beans.Basic.Lists is

   --  Package that represents the vectors of elements.
   --  (gcc 4.4 crashes if this package is defined as generic parameter.
   package Vectors is
     new Ada.Containers.Vectors (Element_Type => Element_Type,
                                 Index_Type   => Natural);

   --  The list of elements is defined in a public part so that applications
   --  can easily add or remove elements in the target list.  The List_Bean
   --  type holds the real implementation with the private parts.
   type Abstract_List_Bean is abstract new Ada.Finalization.Controlled
     and Util.Beans.Basic.List_Bean with record
      List : aliased Vectors.Vector;
   end record;

   --  ------------------------------
   --  List of objects
   --  ------------------------------
   --  The List_Bean type gives access to a list of objects.
   type List_Bean is new Abstract_List_Bean with private;
   type List_Bean_Access is access all List_Bean'Class;

   --  Get the number of elements in the list.
   overriding
   function Get_Count (From : in List_Bean) return Natural;

   --  Set the current row index.  Valid row indexes start at 1.
   overriding
   procedure Set_Row_Index (From  : in out List_Bean;
                            Index : in Natural);

   --  Get the element at the current row index.
   overriding
   function Get_Row (From  : in List_Bean) return Util.Beans.Objects.Object;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Initialize the list bean.
   overriding
   procedure Initialize (Object : in out List_Bean);

   --  Deletes the list bean
   procedure Free (List : in out Util.Beans.Basic.Readonly_Bean_Access);

private

   type List_Bean is new Abstract_List_Bean with record
      Current : aliased Element_Type;
      Row     : Util.Beans.Objects.Object;
   end record;

end Util.Beans.Basic.Lists;

Make the List an aliased member to help the Rest operations


-----------------------------------------------------------------------
--  Util.Concurrent.Copies -- Concurrent Tools
--  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.Concurrent.Copies is

   protected body Atomic is
      --  ------------------------------
      --  Get the value atomically
      --  ------------------------------
      function Get return Element_Type is
      begin
         return Value;
      end Get;

      --  ------------------------------
      --  Change the value atomically.
      --  ------------------------------
      procedure Set (Object : in Element_Type) is
      begin
         Value := Object;
      end Set;

   end Atomic;

end Util.Concurrent.Copies;

-----------------------------------------------------------------------
--  util-concurrent-copies -- Concurrent Tools
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package body Util.Concurrent.Copies is

   protected body Atomic is
      --  ------------------------------
      --  Get the value atomically
      --  ------------------------------
      function Get return Element_Type is
      begin
         return Value;
      end Get;

      --  ------------------------------
      --  Change the value atomically.
      --  ------------------------------
      procedure Set (Object : in Element_Type) is
      begin
         Value := Object;
      end Set;

   end Atomic;

end Util.Concurrent.Copies;

Update the header

Update the header