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

--  The <bASF.Components describes the components that form the
--  tree view.  Each component has attributes and children.  Children
--  represent sub-components and attributes control the rendering and
--  behavior of the component.
--
--  The component tree is created from the ASF.Views tag nodes
--  for each request.  Unlike tag nodes, the component tree is not shared.
with Ada.Strings.Unbounded;
with EL.Objects;
with EL.Expressions;
--  with EL.Contexts;
with ASF.Contexts.Faces;
--  limited with ASF.Contexts.Facelets;
limited with ASF.Views.Nodes;
limited with ASF.Converters;
package ASF.Components is

   use Ada.Strings.Unbounded;
   use ASF.Contexts.Faces;
   type UIComponent_List is private;

   --  ------------------------------
   --  Attribute of a component
   --  ------------------------------
   type UIAttribute is private;

--     type UIComponent is new Ada.Finalization.Controlled with private;
   type UIComponent is tagged limited private;
   type UIComponent_Access is access all UIComponent'Class;

   --  Get the parent component.
   --  Returns null if the node is the root element.
   function Get_Parent (UI : UIComponent) return UIComponent_Access;

   --  Return a client-side identifier for this component, generating
   --  one if necessary.
   function Get_Client_Id (UI : UIComponent) return Unbounded_String;

   --  Get the list of children.
   function Get_Children (UI : UIComponent) return UIComponent_List;

   --  Get the number of children.
   function Get_Children_Count (UI : UIComponent) return Natural;

   --  Get the first child component.
   --  Returns null if the component has no children.
   function Get_First_Child (UI : UIComponent) return UIComponent_Access;

   --  Initialize the component when restoring the view.
   --  The default initialization gets the client ID and allocates it if necessary.
   procedure Initialize (UI      : in out UIComponent;
                         Context : in out Faces_Context'Class);

   procedure Append (UI    : in UIComponent_Access;
                     Child : in UIComponent_Access;
                     Tag   : access ASF.Views.Nodes.Tag_Node'Class);

   --  Search for and return the {@link UIComponent} with an id
   --  that matches the specified search expression (if any), according to
   --  the algorithm described below.
   function Find (UI : UIComponent;
                  Name : String) return UIComponent_Access;

   --  Check whether the component and its children must be rendered.
   function Is_Rendered (UI : UIComponent;
                         Context : Faces_Context'Class) return Boolean;

   --  Set whether the component is rendered.
   procedure Set_Rendered (UI       : in out UIComponent;
                           Rendered : in Boolean);

   function Get_Attribute (UI      : UIComponent;
                           Context : Faces_Context'Class;
                           Name    : String) return EL.Objects.Object;

   --  Get the attribute tag
   function Get_Attribute (UI      : UIComponent;
                           Name    : String) return access ASF.Views.Nodes.Tag_Attribute;

   procedure Set_Attribute (UI    : in out UIComponent;
                            Name  : in String;
                            Value : in EL.Objects.Object);

   procedure Set_Attribute (UI    : in out UIComponent;
                            Def   : access ASF.Views.Nodes.Tag_Attribute;
                            Value : in EL.Expressions.Expression);

   --  Get the converter associated with the component
   function Get_Converter (UI      : in UIComponent;
                           Context : in Faces_Context'Class)
                           return access ASF.Converters.Converter'Class;

   --  Convert the string into a value.  If a converter is specified on the component,
   --  use it to convert the value.
   function Convert_Value (UI      : in UIComponent;
                           Value   : in String;
                           Context : in Faces_Context'Class) return EL.Objects.Object;

   --  Get the value expression
   function Get_Value_Expression (UI   : in UIComponent;
                                  Name : in String) return EL.Expressions.Value_Expression;

   procedure Encode_Begin (UI      : in UIComponent;
                           Context : in out Faces_Context'Class);

   procedure Encode_Children (UI      : in UIComponent;
                              Context : in out Faces_Context'Class);

   procedure Encode_End (UI      : in UIComponent;
                         Context : in out Faces_Context'Class);

   procedure Encode_All (UI      : in UIComponent'Class;
                         Context : in out Faces_Context'Class);

   procedure Decode (UI      : in out UIComponent;
                     Context : in out Faces_Context'Class);

   procedure Decode_Children (UI      : in UIComponent'Class;
                              Context : in out Faces_Context'Class);

   procedure Process_Decodes (UI      : in out UIComponent;
                              Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   procedure Process_Validators (UI      : in out UIComponent;
                                 Context : in out Faces_Context'Class);

   procedure Process_Updates (UI      : in out UIComponent;
                              Context : in out Faces_Context'Class);

   type UIComponent_Array is array (Natural range <>) of UIComponent_Access;

   type UIComponent_Array_Access is access UIComponent_Array;

   --  type UIOutput is new UIComponent;

   function Get_Context (UI : in UIComponent)
                         return ASF.Contexts.Faces.Faces_Context_Access;

   --  Get the attribute value.
   function Get_Value (Attr : UIAttribute;
                       UI   : UIComponent'Class) return EL.Objects.Object;

--   function Create_UIComponent (Parent  : UIComponent_Access;
--                                Context : ASF.Contexts.Facelets.Facelet_Context'Class;
--                                Tag    : access ASF.Views.Nodes.Tag_Node'Class)
--                                return UIComponent_Access;

   --  Iterate over the children of the component and execute
   --  the Process procedure.
   generic
      with procedure Process (Child   : in UIComponent_Access);
   procedure Iterate (UI : in UIComponent'Class);

   --  Iterate over the attributes defined on the component and
   --  execute the Process procedure.
   generic
      with procedure Process (Name : in String;
                              Attr : in UIAttribute);
   procedure Iterate_Attributes (UI : in UIComponent'Class);

private

   --  Delete the component tree recursively.
   procedure Delete (UI : in out UIComponent_Access);

   type UIAttribute_Access is access all UIAttribute;

   type UIAttribute is record
      Definition : access ASF.Views.Nodes.Tag_Attribute;
      Name       : Unbounded_String;
      Value      : EL.Objects.Object;
      Expr       : El.Expressions.Expression;
      Next_Attr  : UIAttribute_Access;
   end record;

   type UIComponent_List is record
      Child : UIComponent_Access := null;
   end record;

   type UIComponent is tagged limited record
      Id          : Unbounded_String;
      Tag         : access ASF.Views.Nodes.Tag_Node'Class;
      Parent      : UIComponent_Access;
      First_Child : UIComponent_Access;
      Last_Child  : UIComponent_Access;
      Next        : UIComponent_Access;
      Attributes  : UIAttribute_Access;
   end record;

end ASF.Components;

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

--  The <bASF.Components describes the components that form the
--  tree view.  Each component has attributes and children.  Children
--  represent sub-components and attributes control the rendering and
--  behavior of the component.
--
--  The component tree is created from the ASF.Views tag nodes
--  for each request.  Unlike tag nodes, the component tree is not shared.
with Ada.Strings.Unbounded;
with EL.Objects;
with EL.Expressions;
--  with EL.Contexts;
with ASF.Contexts.Faces;
--  limited with ASF.Contexts.Facelets;
limited with ASF.Views.Nodes;
limited with ASF.Converters;
package ASF.Components is

   use Ada.Strings.Unbounded;
   use ASF.Contexts.Faces;
   type UIComponent_List is private;

   --  ------------------------------
   --  Attribute of a component
   --  ------------------------------
   type UIAttribute is private;

--     type UIComponent is new Ada.Finalization.Controlled with private;
   type UIComponent is tagged limited private;
   type UIComponent_Access is access all UIComponent'Class;

   --  Get the parent component.
   --  Returns null if the node is the root element.
   function Get_Parent (UI : UIComponent) return UIComponent_Access;

   --  Return a client-side identifier for this component, generating
   --  one if necessary.
   function Get_Client_Id (UI : UIComponent) return Unbounded_String;

   --  Get the list of children.
   function Get_Children (UI : UIComponent) return UIComponent_List;

   --  Get the number of children.
   function Get_Children_Count (UI : UIComponent) return Natural;

   --  Get the first child component.
   --  Returns null if the component has no children.
   function Get_First_Child (UI : UIComponent) return UIComponent_Access;

   --  Initialize the component when restoring the view.
   --  The default initialization gets the client ID and allocates it if necessary.
   procedure Initialize (UI      : in out UIComponent;
                         Context : in out Faces_Context'Class);

   procedure Append (UI    : in UIComponent_Access;
                     Child : in UIComponent_Access;
                     Tag   : access ASF.Views.Nodes.Tag_Node'Class);

   --  Search for and return the {@link UIComponent} with an id
   --  that matches the specified search expression (if any), according to
   --  the algorithm described below.
   function Find (UI : UIComponent;
                  Name : String) return UIComponent_Access;

   --  Check whether the component and its children must be rendered.
   function Is_Rendered (UI : UIComponent;
                         Context : Faces_Context'Class) return Boolean;

   --  Set whether the component is rendered.
   procedure Set_Rendered (UI       : in out UIComponent;
                           Rendered : in Boolean);

   function Get_Attribute (UI      : UIComponent;
                           Context : Faces_Context'Class;
                           Name    : String) return EL.Objects.Object;

   --  Get the attribute tag
   function Get_Attribute (UI      : UIComponent;
                           Name    : String) return access ASF.Views.Nodes.Tag_Attribute;

   procedure Set_Attribute (UI    : in out UIComponent;
                            Name  : in String;
                            Value : in EL.Objects.Object);

   procedure Set_Attribute (UI    : in out UIComponent;
                            Def   : access ASF.Views.Nodes.Tag_Attribute;
                            Value : in EL.Expressions.Expression);

   --  Get the converter associated with the component
   function Get_Converter (UI      : in UIComponent;
                           Context : in Faces_Context'Class)
                           return access ASF.Converters.Converter'Class;

   --  Convert the string into a value.  If a converter is specified on the component,
   --  use it to convert the value.
   function Convert_Value (UI      : in UIComponent;
                           Value   : in String;
                           Context : in Faces_Context'Class) return EL.Objects.Object;

   --  Get the value expression
   function Get_Value_Expression (UI   : in UIComponent;
                                  Name : in String) return EL.Expressions.Value_Expression;

   procedure Encode_Begin (UI      : in UIComponent;
                           Context : in out Faces_Context'Class);

   procedure Encode_Children (UI      : in UIComponent;
                              Context : in out Faces_Context'Class);

   procedure Encode_End (UI      : in UIComponent;
                         Context : in out Faces_Context'Class);

   procedure Encode_All (UI      : in UIComponent'Class;
                         Context : in out Faces_Context'Class);

   procedure Decode (UI      : in out UIComponent;
                     Context : in out Faces_Context'Class);

   procedure Decode_Children (UI      : in UIComponent'Class;
                              Context : in out Faces_Context'Class);

   procedure Process_Decodes (UI      : in out UIComponent;
                              Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   procedure Process_Validators (UI      : in out UIComponent;
                                 Context : in out Faces_Context'Class);

   procedure Process_Updates (UI      : in out UIComponent;
                              Context : in out Faces_Context'Class);

   type UIComponent_Array is array (Natural range <>) of UIComponent_Access;

   type UIComponent_Array_Access is access UIComponent_Array;

   --  type UIOutput is new UIComponent;

   function Get_Context (UI : in UIComponent)
                         return ASF.Contexts.Faces.Faces_Context_Access;

   --  Get the attribute value.
   function Get_Value (Attr : UIAttribute;
                       UI   : UIComponent'Class) return EL.Objects.Object;

--   function Create_UIComponent (Parent  : UIComponent_Access;
--                                Context : ASF.Contexts.Facelets.Facelet_Context'Class;
--                                Tag    : access ASF.Views.Nodes.Tag_Node'Class)
--                                return UIComponent_Access;

   --  Iterate over the children of the component and execute
   --  the Process procedure.
   generic
      with procedure Process (Child   : in UIComponent_Access);
   procedure Iterate (UI : in UIComponent'Class);

   --  Iterate over the attributes defined on the component and
   --  execute the Process procedure.
   generic
      with procedure Process (Name : in String;
                              Attr : in UIAttribute);
   procedure Iterate_Attributes (UI : in UIComponent'Class);

   --  ------------------------------
   --  Value Holder
   --  ------------------------------
   type Value_Holder is limited interface;

   --  Get the local value of the component without evaluating
   --  the associated Value_Expression.
   function Get_Local_Value (Holder : in Value_Holder) return EL.Objects.Object is abstract;

   --  Get the value of the component.  If the component has a local
   --  value which is not null, returns it.  Otherwise, if we have a Value_Expression
   --  evaluate and returns the value.
   function Get_Value (Holder : in Value_Holder) return EL.Objects.Object is abstract;

   --  Set the value of the component.
   procedure Set_Value (Holder : in out Value_Holder;
                        Value  : in EL.Objects.Object) is abstract;

   --  Get the converter that is registered on the component.
   function Get_Converter (Holder : in Value_Holder)
                           return access ASF.Converters.Converter'Class is abstract;

   --  Set the converter to be used on the component.
   procedure Set_Converter (Holder    : in out Value_Holder;
                            Converter : access ASF.Converters.Converter'Class) is abstract;

private

   --  Delete the component tree recursively.
   procedure Delete (UI : in out UIComponent_Access);

   type UIAttribute_Access is access all UIAttribute;

   type UIAttribute is record
      Definition : access ASF.Views.Nodes.Tag_Attribute;
      Name       : Unbounded_String;
      Value      : EL.Objects.Object;
      Expr       : El.Expressions.Expression;
      Next_Attr  : UIAttribute_Access;
   end record;

   type UIComponent_List is record
      Child : UIComponent_Access := null;
   end record;

   type UIComponent is tagged limited record
      Id          : Unbounded_String;
      Tag         : access ASF.Views.Nodes.Tag_Node'Class;
      Parent      : UIComponent_Access;
      First_Child : UIComponent_Access;
      Last_Child  : UIComponent_Access;
      Next        : UIComponent_Access;
      Attributes  : UIAttribute_Access;
   end record;

end ASF.Components;

Define the Value_Holder interface

Define the Value_Holder interface


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

with Util.Serialize.Mappers;

with AWA.Events.Queues.Fifos;
with AWA.Events.Queues.Persistents;
package body AWA.Events.Queues is

   --  ------------------------------
   --  Queue the event.
   --  ------------------------------
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class) is
      Q : constant Queue_Info_Access := Into.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Enqueue (Event);
   end Enqueue;

   --  ------------------------------
   --  Dequeue an event and process it with the Process procedure.
   --  ------------------------------
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Q : constant Queue_Info_Access := From.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Dequeue (Process);
   end Dequeue;

   --  ------------------------------
   --  Returns true if the reference does not contain any element.
   --  ------------------------------
   function Is_Null (Queue : in Queue_Ref'Class) return Boolean is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      return Q = null or else Q.Queue = null;
   end Is_Null;

   --  ------------------------------
   --  Returns the queue name.
   --  ------------------------------
   function Get_Name (Queue : in Queue_Ref'Class) return String is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null then
         return "";
      else
         return Q.Name;
      end if;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null or else Q.Queue = null then
         return AWA.Events.Models.Null_Queue;
      else
         return Q.Queue.Get_Queue;
      end if;
   end Get_Queue;

   FIFO_QUEUE_TYPE       : constant String := "fifo";
   PERSISTENT_QUEUE_TYPE : constant String := "persist";

   --  ------------------------------
   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref is
      Result : Queue_Ref;
      Q      : constant Queue_Info_Access := new Queue_Info '(Util.Refs.Ref_Entity with
                                                              Length => Name'Length,
                                                              Name   => Name,
                                                              others => <>);
   begin
      Queue_Refs.Ref (Result) := Queue_Refs.Create (Q);
      if Kind = FIFO_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Fifos.Create_Queue (Name, Props, Context);
      elsif Name = PERSISTENT_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Persistents.Create_Queue (Name, Props, Context);
      else
         raise Util.Serialize.Mappers.Field_Error with "Invalid queue type: " & Name;
      end if;
      return Result;
   end Create_Queue;

   function Null_Queue return Queue_Ref is
      Result : Queue_Ref;
   begin
      return Result;
   end Null_Queue;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Queue_Info) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Queue'Class,
                                         Name   => Queue_Access);
   begin
      if Object.Queue /= null then
         Object.Queue.Finalize;
         Free (Object.Queue);
      end if;
   end Finalize;

end AWA.Events.Queues;

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

with Util.Serialize.Mappers;

with AWA.Events.Queues.Fifos;
with AWA.Events.Queues.Persistents;
package body AWA.Events.Queues is

   --  ------------------------------
   --  Queue the event.
   --  ------------------------------
   procedure Enqueue (Into  : in Queue_Ref;
                      Event : in AWA.Events.Module_Event'Class) is
      Q : constant Queue_Info_Access := Into.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Enqueue (Event);
   end Enqueue;

   --  ------------------------------
   --  Dequeue an event and process it with the Process procedure.
   --  ------------------------------
   procedure Dequeue (From    : in Queue_Ref;
                      Process : access procedure (Event : in Module_Event'Class)) is
      Q : constant Queue_Info_Access := From.Value;
   begin
      if Q = null or else Q.Queue = null then
         return;
      end if;
      Q.Queue.Dequeue (Process);
   end Dequeue;

   --  ------------------------------
   --  Returns true if the reference does not contain any element.
   --  ------------------------------
   function Is_Null (Queue : in Queue_Ref'Class) return Boolean is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      return Q = null or else Q.Queue = null;
   end Is_Null;

   --  ------------------------------
   --  Returns the queue name.
   --  ------------------------------
   function Get_Name (Queue : in Queue_Ref'Class) return String is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null then
         return "";
      else
         return Q.Name;
      end if;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   function Get_Queue (Queue : in Queue_Ref'Class) return AWA.Events.Models.Queue_Ref is
      Q : constant Queue_Info_Access := Queue.Value;
   begin
      if Q = null or else Q.Queue = null then
         return AWA.Events.Models.Null_Queue;
      else
         return Q.Queue.Get_Queue;
      end if;
   end Get_Queue;

   FIFO_QUEUE_TYPE       : constant String := "fifo";
   PERSISTENT_QUEUE_TYPE : constant String := "persist";

   --  ------------------------------
   --  Create the event queue identified by the name Name.  The queue factory
   --  identified by Kind is called to create the event queue instance.
   --  Returns a reference to the queue.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Kind    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class)
                          return Queue_Ref is
      Result : Queue_Ref;
      Q      : constant Queue_Info_Access := new Queue_Info '(Util.Refs.Ref_Entity with
                                                              Length => Name'Length,
                                                              Name   => Name,
                                                              others => <>);
   begin
      Queue_Refs.Ref (Result) := Queue_Refs.Create (Q);
      if Kind = FIFO_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Fifos.Create_Queue (Name, Props, Context);
      elsif Kind = PERSISTENT_QUEUE_TYPE then
         Q.Queue := AWA.Events.Queues.Persistents.Create_Queue (Name, Props, Context);
      else
         raise Util.Serialize.Mappers.Field_Error with "Invalid queue type: " & Kind;
      end if;
      return Result;
   end Create_Queue;

   function Null_Queue return Queue_Ref is
      Result : Queue_Ref;
   begin
      return Result;
   end Null_Queue;

   --  ------------------------------
   --  Finalize the referenced object.  This is called before the object is freed.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Queue_Info) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Queue'Class,
                                         Name   => Queue_Access);
   begin
      if Object.Queue /= null then
         Object.Queue.Finalize;
         Free (Object.Queue);
      end if;
   end Finalize;

end AWA.Events.Queues;

Fix creation of event queue

Fix creation of event queue


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

with AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

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

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Access);

      Plugin.Key_Filter.Initialize (App.all);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

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

      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-model -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012, 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 AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

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

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Unchecked_Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Unchecked_Access);

      Plugin.Key_Filter.Initialize (App.all);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

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

      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

Fix compilation

Fix compilation


with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Exceptions;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Smart_Pointers;
with Types.Vector;
with Types.Hash_Map;

package body Reader is

   package ACL renames Ada.Characters.Latin_1;

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

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set
       (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma);

   -- [^\s\[\]{}('"`,;)]
   Terminator_Syms : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Lisp_Whitespace,
        Ada.Strings.Maps.To_Set ("[]{}('""`,;)"));

   -- This is raised if an invalid character is encountered
   Lexical_Error : exception;

   -- The unterminated string error
   String_Error : exception;

   function Convert_String (S : String) return String is
      use Ada.Strings.Unbounded;
      Res : Unbounded_String;
      I : Positive;
      Str_Last : Natural;
   begin
      Str_Last := S'Last;
      I := S'First;
      while I <= Str_Last loop
         if S (I) = '\' then
            if I+1 > Str_Last then
               Append (Res, S (I));
               I := I + 1;
            elsif S (I+1) = 'n' then
               Append (Res, Ada.Characters.Latin_1.LF);
               I := I + 2;
            elsif S (I+1) = '"' then
               Append (Res, S (I+1));
               I := I + 2;
            elsif S (I+1) = '\' then
               Append (Res, S (I+1));
               I := I + 2;
            else
               Append (Res, S (I));
               I := I + 1;
            end if;
         else
            Append (Res, S (I));
            I := I + 1;
         end if;
      end loop;
      return To_String (Res);
   end Convert_String;

   subtype String_Indices is Integer range 0 .. Max_Line_Len;

   Str_Len : String_Indices := 0;
   Saved_Line : String (1..Max_Line_Len);
   Char_To_Read : String_Indices := 1;

   function Get_Token return Types.Mal_Handle is
      use Types;
      Res : Types.Mal_Handle;
      I, J : String_Indices;
      Dots : Natural;
      All_Digits : Boolean;
   begin

      <<Tail_Call_Opt>>
      I := Char_To_Read;
      while I <= Str_Len and then
            Ada.Strings.Maps.Is_In (Saved_Line (I), Lisp_Whitespace) loop
         I := I + 1;
      end loop;

      -- Filter out lines consisting of only whitespace
      if I > Str_Len then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      J := I;
      case Saved_Line (J) is
         when '~' => -- Circumflex
            if J+1 <= Str_Len and then Saved_Line(J+1) = '@' then
               Res := New_Unitary_Mal_Type
                 (Func => Splice_Unquote,
                  Op => Smart_Pointers.Null_Smart_Pointer);
               Char_To_Read := J+2;
            else
               -- Just a circumflex
               Res := New_Atom_Mal_Type (Saved_Line (J..J));
               Char_To_Read := J+1;
            end if;
         when '[' | ']' |
              '{' | '}' |
              '(' | ')' |
              ''' | '`' |
              '^' | '@' =>

            Res := New_Atom_Mal_Type (Saved_Line (J..J));
            Char_To_Read := J+1;

         when '"' => -- a string

            -- Skip over "
            J := J + 1;
            while J <= Str_Len and then
               (Saved_Line (J) /= '"' or else
                 Saved_Line (J-1) = '\') loop
               J := J + 1;
            end loop;

            -- So we either ran out of string..
            if J > Str_Len then
               raise String_Error;
            end if;

            -- or we reached an unescaped "
            Res := New_String_Mal_Type
              (Str => Convert_String (Saved_Line (I .. J)));
            Char_To_Read := J + 1;

         when ';' => -- a comment

            -- Read to the end of the line or until
            -- the saved_line string is exhausted.
            -- NB if we reach the end we don't care
            -- what the last char was.
            while J < Str_Len and Saved_Line (J) /= ACL.LF loop
               J := J + 1;
            end loop;
            if J = Str_Len then
               Res := Smart_Pointers.Null_Smart_Pointer;
            else
               Char_To_Read := J + 1;
               -- was: Res := Get_Token;
               goto Tail_Call_Opt;
            end if;

         when others => -- an atom

            while J <= Str_Len and then
               not Ada.Strings.Maps.Is_In (Saved_Line (J), Terminator_Syms) loop
               J := J + 1;
            end loop;

            -- Either we ran out of string or
            -- the one at J was the start of a new token
            Char_To_Read := J;
            J := J - 1;

            -- check if all digits or .
            Dots := 0;
            All_Digits := True;
            for K in I .. J loop
               if Saved_Line (K) = '.' then
                  Dots := Dots + 1;
               elsif not (Saved_Line (K) in '0' .. '9') then
                  All_Digits := False;
                  exit;
               end if;
            end loop;

            if All_Digits then
               if Dots = 0 then
                  Res := New_Int_Mal_Type
                    (Int => Mal_Integer'Value (Saved_Line (I .. J)));
               elsif Dots = 1 then
                  Res := New_Float_Mal_Type
                    (Floating => Mal_Float'Value (Saved_Line (I..J)));
               else
                  Res := New_Atom_Mal_Type (Saved_Line (I..J));
               end if;
            else
               Res := New_Atom_Mal_Type (Saved_Line (I..J));
            end if;

      end case;

      return Res;

   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Handle;

   function Read_List (LT : Types.List_Types)
   return Types.Mal_Handle is

      use Types;
      MTA : Mal_Handle;

   begin

      MTA := Read_Form;

      if Deref (MTA).Sym_Type = Atom and then
         Deref_Atom (MTA).Get_Atom = "fn*" then

         declare
            Params, Expr, Close_Lambda : Mal_Handle;
         begin
            Params := Read_Form;
            Expr := Read_Form;
            Close_Lambda := Read_Form;  -- the ) at the end of the lambda
            return New_Lambda_Mal_Type (Params, Expr);
         exception
            when Lexical_Error =>

              -- List_MT about to go out of scope but its a Mal_Handle
              -- so it is automatically garbage collected.

              return New_Error_Mal_Type (Str => "Lexical error in fn*");

         end;

      else

         declare
            List_SP : Mal_Handle;
            List_P : List_Class_Ptr;
            Close : String (1..1) := (1 => Types.Closing (LT));
         begin
            case LT is
               when List_List =>
                  List_SP := New_List_Mal_Type (List_Type => LT);
               when Vector_List =>
                  List_SP := Vector.New_Vector_Mal_Type;
               when Hashed_List =>
                  List_SP := Hash_Map.New_Hash_Map_Mal_Type;
            end case;

            -- Need to append to a variable so...
            List_P := Deref_List_Class (List_SP);
            loop
               exit when Is_Null (MTA) or else
                         (Deref (MTA).Sym_Type = Atom and then
                          Atom_Mal_Type (Deref (MTA).all).Get_Atom = Close);
               Append (List_P.all, MTA);
               MTA := Read_Form;
            end loop;
            return List_SP;
         exception
            when Lexical_Error =>

              -- List_MT about to go out of scope but its a Mal_Handle
              -- so it is automatically garbage collected.

              return New_Error_Mal_Type (Str => "expected '" & Close & "'");

         end;
      end if;

   exception
      when Lexical_Error =>

        return New_Error_Mal_Type (Str => "Lexical error in Read_List");

   end Read_List;

   function Read_Form return Types.Mal_Handle is
      use Types;
      MTS : Mal_Handle;
   begin

      MTS := Get_Token;

      if Is_Null (MTS) then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      if Deref (MTS).Sym_Type = Atom then

         declare
            Symbol : String := Atom_Mal_Type (Deref (MTS).all).Get_Atom;
         begin
            -- Listy things and quoting...
            if Symbol = "(" then
               return Read_List (List_List);
            elsif Symbol = "[" then
               return Read_List (Vector_List);
            elsif Symbol = "{" then
               return Read_List (Hashed_List);
            elsif Symbol = "^" then
               declare
                  Meta, Obj : Mal_Handle;
               begin
                  Meta := Read_Form;
                  Obj := Read_Form;
                  declare
                     MT : Mal_Ptr := Deref (Obj);
                  begin
                     Set_Meta (MT.all, Meta);
                  end;
                  return Obj;
               end;
            elsif Symbol = ACL.Apostrophe & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("quote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Grave & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("quasiquote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Tilde & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("unquote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Commercial_At & "" then
               return New_Unitary_Mal_Type (Func => Deref, Op => Read_Form);
            else
               return MTS;
            end if;
         end;

      elsif Deref(MTS).Sym_Type = Unitary and then
            Unitary_Mal_Type (Deref (MTS).all).Get_Func = Splice_Unquote then

         declare
            List_SP : Mal_Handle;
            List_P : List_Ptr;
         begin
            List_SP := New_List_Mal_Type (List_Type => List_List);
            List_P := Deref_List (List_SP);
            Append (List_P.all, New_Atom_Mal_Type ("splice-unquote"));
            Append (List_P.all, Read_Form);
            return List_SP;
         end;

      else
         return MTS;
      end if;

   exception
      when String_Error =>
        return New_Error_Mal_Type (Str => "expected '""'");
   end Read_Form;

   procedure Lex_Init (S : String) is
   begin
      Str_Len := S'Length;
      Saved_Line (1..S'Length) := S;  -- Needed for error recovery
      Char_To_Read := 1;
   end Lex_Init;

   function Read_Str (S : String) return Types.Mal_Handle is
      I, Str_Len : Natural := S'Length;
   begin

      Lex_Init (S);

      return Read_Form;

   end Read_Str;

end Reader;

with Ada.IO_Exceptions;
with Ada.Characters.Latin_1;
with Ada.Exceptions;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Smart_Pointers;
with Types.Vector;
with Types.Hash_Map;

package body Reader is

   use Types;

   package ACL renames Ada.Characters.Latin_1;

   type Lexemes is (Whitespace, Comment,
                    Int_Tok, Float_Tok, Sym_Tok,
                    Nil_Tok, True_Tok, False_Tok,
                    LE_Tok, GE_Tok, Exp_Tok, Splice_Unq_Tok,
                    Str_Tok, Atom_Tok);

   Lisp_Whitespace : constant Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps.To_Set
       (ACL.HT & ACL.LF & ACL.CR & ACL.Space & ACL.Comma);

   -- [^\s\[\]{}('"`,;)]
   Terminator_Syms : Ada.Strings.Maps.Character_Set :=
     Ada.Strings.Maps."or"
       (Lisp_Whitespace,
        Ada.Strings.Maps.To_Set ("[]{}('""`,;)"));

   -- The unterminated string error
   String_Error : exception;

   function Convert_String (S : String) return String is
      use Ada.Strings.Unbounded;
      Res : Unbounded_String;
      I : Positive;
      Str_Last : Natural;
   begin
      Str_Last := S'Last;
      I := S'First;
      while I <= Str_Last loop
         if S (I) = '\' then
            if I+1 > Str_Last then
               Append (Res, S (I));
               I := I + 1;
            elsif S (I+1) = 'n' then
               Append (Res, Ada.Characters.Latin_1.LF);
               I := I + 2;
            elsif S (I+1) = '"' then
               Append (Res, S (I+1));
               I := I + 2;
            elsif S (I+1) = '\' then
               Append (Res, S (I+1));
               I := I + 2;
            else
               Append (Res, S (I));
               I := I + 1;
            end if;
         else
            Append (Res, S (I));
            I := I + 1;
         end if;
      end loop;
      return To_String (Res);
   end Convert_String;

   subtype String_Indices is Integer range 0 .. Max_Line_Len;

   Str_Len : String_Indices := 0;
   Saved_Line : String (1..Max_Line_Len);
   Char_To_Read : String_Indices := 1;

   function Get_Token return Types.Mal_Handle is
      Res : Types.Mal_Handle;
      I, J : String_Indices;
      Dots : Natural;
      All_Digits : Boolean;
   begin

      <<Tail_Call_Opt>>
      I := Char_To_Read;
      while I <= Str_Len and then
            Ada.Strings.Maps.Is_In (Saved_Line (I), Lisp_Whitespace) loop
         I := I + 1;
      end loop;

      -- Filter out lines consisting of only whitespace
      if I > Str_Len then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      J := I;
      case Saved_Line (J) is
         when '~' => -- Circumflex
            if J+1 <= Str_Len and then Saved_Line(J+1) = '@' then
               Res := New_Unitary_Mal_Type
                 (Func => Splice_Unquote,
                  Op => Smart_Pointers.Null_Smart_Pointer);
               Char_To_Read := J+2;
            else
               -- Just a circumflex
               Res := New_Atom_Mal_Type (Saved_Line (J..J));
               Char_To_Read := J+1;
            end if;
         when '[' | ']' |
              '{' | '}' |
              '(' | ')' |
              ''' | '`' |
              '^' | '@' =>

            Res := New_Atom_Mal_Type (Saved_Line (J..J));
            Char_To_Read := J+1;

         when '"' => -- a string

            -- Skip over "
            J := J + 1;
            while J <= Str_Len and then
               (Saved_Line (J) /= '"' or else
                 Saved_Line (J-1) = '\') loop
               J := J + 1;
            end loop;

            -- So we either ran out of string..
            if J > Str_Len then
               raise String_Error;
            end if;

            -- or we reached an unescaped "
            Res := New_String_Mal_Type
              (Str => Convert_String (Saved_Line (I .. J)));
            Char_To_Read := J + 1;

         when ';' => -- a comment

            -- Read to the end of the line or until
            -- the saved_line string is exhausted.
            -- NB if we reach the end we don't care
            -- what the last char was.
            while J < Str_Len and Saved_Line (J) /= ACL.LF loop
               J := J + 1;
            end loop;
            if J = Str_Len then
               Res := Smart_Pointers.Null_Smart_Pointer;
            else
               Char_To_Read := J + 1;
               -- was: Res := Get_Token;
               goto Tail_Call_Opt;
            end if;

         when others => -- an atom

            while J <= Str_Len and then
               not Ada.Strings.Maps.Is_In (Saved_Line (J), Terminator_Syms) loop
               J := J + 1;
            end loop;

            -- Either we ran out of string or
            -- the one at J was the start of a new token
            Char_To_Read := J;
            J := J - 1;

            -- check if all digits or .
            Dots := 0;
            All_Digits := True;
            for K in I .. J loop
               if Saved_Line (K) = '.' then
                  Dots := Dots + 1;
               elsif not (Saved_Line (K) in '0' .. '9') then
                  All_Digits := False;
                  exit;
               end if;
            end loop;

            if All_Digits then
               if Dots = 0 then
                  Res := New_Int_Mal_Type
                    (Int => Mal_Integer'Value (Saved_Line (I .. J)));
               elsif Dots = 1 then
                  Res := New_Float_Mal_Type
                    (Floating => Mal_Float'Value (Saved_Line (I..J)));
               else
                  Res := New_Atom_Mal_Type (Saved_Line (I..J));
               end if;
            else
               Res := New_Atom_Mal_Type (Saved_Line (I..J));
            end if;

      end case;

      return Res;

   end Get_Token;

   -- Parsing
   function Read_Form return Types.Mal_Handle;

   function Read_List (LT : Types.List_Types)
   return Types.Mal_Handle is

      MTA : Mal_Handle;

   begin

      MTA := Read_Form;

      if Deref (MTA).Sym_Type = Atom and then
         Deref_Atom (MTA).Get_Atom = "fn*" then

         declare
            Params, Expr, Close_Lambda : Mal_Handle;
         begin
            Params := Read_Form;
            Expr := Read_Form;
            Close_Lambda := Read_Form;  -- the ) at the end of the lambda
            return New_Lambda_Mal_Type (Params, Expr);
         end;

      else

         declare
            List_SP : Mal_Handle;
            List_P : List_Class_Ptr;
            Close : String (1..1) := (1 => Types.Closing (LT));
         begin
            case LT is
               when List_List =>
                  List_SP := New_List_Mal_Type (List_Type => LT);
               when Vector_List =>
                  List_SP := Vector.New_Vector_Mal_Type;
               when Hashed_List =>
                  List_SP := Hash_Map.New_Hash_Map_Mal_Type;
            end case;

            -- Need to append to a variable so...
            List_P := Deref_List_Class (List_SP);
            loop
               if Is_Null (MTA) then
                  return New_Error_Mal_Type (Str => "expected '" & Close & "'");
               end if;
               exit when Deref (MTA).Sym_Type = Atom and then
                          Atom_Mal_Type (Deref (MTA).all).Get_Atom = Close;
               Append (List_P.all, MTA);
               MTA := Read_Form;
            end loop;
            return List_SP;
         end;
      end if;

   end Read_List;

   function Read_Form return Types.Mal_Handle is
      MTS : Mal_Handle;
   begin

      MTS := Get_Token;

      if Is_Null (MTS) then
         return Smart_Pointers.Null_Smart_Pointer;
      end if;

      if Deref (MTS).Sym_Type = Atom then

         declare
            Symbol : String := Atom_Mal_Type (Deref (MTS).all).Get_Atom;
         begin
            -- Listy things and quoting...
            if Symbol = "(" then
               return Read_List (List_List);
            elsif Symbol = "[" then
               return Read_List (Vector_List);
            elsif Symbol = "{" then
               return Read_List (Hashed_List);
            elsif Symbol = "^" then
               declare
                  Meta, Obj : Mal_Handle;
               begin
                  Meta := Read_Form;
                  Obj := Read_Form;
                  declare
                     MT : Mal_Ptr := Deref (Obj);
                  begin
                     Set_Meta (MT.all, Meta);
                  end;
                  return Obj;
               end;
            elsif Symbol = ACL.Apostrophe & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("quote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Grave & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("quasiquote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Tilde & "" then

               declare
                  List_SP : Mal_Handle;
                  List_P : List_Ptr;
               begin
                  List_SP := New_List_Mal_Type (List_Type => List_List);
                  List_P := Deref_List (List_SP);
                  Append (List_P.all, New_Atom_Mal_Type ("unquote"));
                  Append (List_P.all, Read_Form);
                  return List_SP;
               end;

            elsif Symbol = ACL.Commercial_At & "" then
               return New_Unitary_Mal_Type (Func => Deref, Op => Read_Form);
            else
               return MTS;
            end if;
         end;

      elsif Deref(MTS).Sym_Type = Unitary and then
            Unitary_Mal_Type (Deref (MTS).all).Get_Func = Splice_Unquote then

         declare
            List_SP : Mal_Handle;
            List_P : List_Ptr;
         begin
            List_SP := New_List_Mal_Type (List_Type => List_List);
            List_P := Deref_List (List_SP);
            Append (List_P.all, New_Atom_Mal_Type ("splice-unquote"));
            Append (List_P.all, Read_Form);
            return List_SP;
         end;

      else
         return MTS;
      end if;

   end Read_Form;

   procedure Lex_Init (S : String) is
   begin
      Str_Len := S'Length;
      Saved_Line (1..S'Length) := S;
      Char_To_Read := 1;
   end Lex_Init;

   function Read_Str (S : String) return Types.Mal_Handle is
      I, Str_Len : Natural := S'Length;
   begin

      Lex_Init (S);

      return Read_Form;

   exception
      when String_Error =>
        return New_Error_Mal_Type (Str => "expected '""'");
   end Read_Str;

end Reader;

clean up error handling in reader

Ada: clean up error handling in reader


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

package body Util.Encoders.Base64 is

   use Interfaces;
   use Ada;

   use type Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base64 output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      Pos      : Streams.Stream_Element_Offset := Into'First;
      I        : Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Unsigned_8;

      Alphabet : constant Alphabet_Access := E.Alphabet;

   begin
      while I <= Data'Last loop
         if Pos + 4 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Encode the first byte, add padding if necessary.
         C1 := Unsigned_8 (Data (I));
         Into (Pos) := Alphabet (Shift_Right (C1, 2));
         if I = Data'Last then
            Into (Pos + 1) := Alphabet (Shift_Left (C1 and 3, 4));
            Into (Pos + 2) := Character'Pos ('=');
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the second byte, add padding if necessary.
         C2 := Unsigned_8 (Data (I + 1));
         Into (Pos + 1) := Alphabet (Shift_Left (C1 and 16#03#, 4) or Shift_Right (C2, 4));
         if I = Data'Last - 1 then
            Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2));
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the third byte
         C1 := Unsigned_8 (Data (I + 2));
         Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2) or Shift_Right (C1, 6));
         Into (Pos + 3) := Alphabet (C1 and 16#03F#);
         Pos := Pos + 4;
         I   := I + 3;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Alphabet := BASE64_URL_ALPHABET'Access;
      else
         E.Alphabet := BASE64_ALPHABET'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Encoder return Transformer_Access is
   begin
      return new Encoder '(Alphabet => BASE64_URL_ALPHABET'Access);
   end Create_URL_Encoder;

   --  ------------------------------
   --  Decodes the base64 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      use Ada.Streams;

      Pos      : Streams.Stream_Element_Offset := Into'First;
      I        : Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Streams.Stream_Element;
      Val1, Val2 : Unsigned_8;

      Values : constant Alphabet_Values_Access := E.Values;

   begin
      while I <= Data'Last loop
         if Pos + 3 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Decode the first two bytes to produce the first output byte
         C1 := Data (I);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
         end if;

         C2 := Data (I + 1);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
         end if;

         Into (Pos) := Stream_Element (Shift_Left (Val1, 2) or Shift_Right (Val2, 4));

         if I + 2 > Data'Last then
            Encoded := I + 1;
            Last    := Pos;
            return;
         end if;

         --  Decode the next byte
         C1 := Data (I + 2);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            if C1 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos;
            return;
         end if;

         Into (Pos + 1) := Stream_Element (Shift_Left (Val2, 4) or Shift_Right (Val1, 2));

         if I + 3 > Data'Last then
            Encoded := I + 2;
            Last    := Pos + 1;
            return;
         end if;

         C2 := Data (I + 3);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            if C2 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos + 1;
            return;
         end if;

         Into (Pos + 2) := Stream_Element (Shift_Left (Val1, 6) or Val2);
         Pos := Pos + 3;
         I   := I + 4;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Values := BASE64_URL_VALUES'Access;
      else
         E.Values := BASE64_VALUES'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Decoder return Transformer_Access is
   begin
      return new Decoder '(Values => BASE64_URL_VALUES'Access);
   end Create_URL_Decoder;

end Util.Encoders.Base64;

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

   use Interfaces;
   use Ada;

   use type Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Encode the 64-bit value to LEB128 and then base64url.
   --  ------------------------------
   function Encode (Value : in Interfaces.Unsigned_64) return String is
      E       : Encoder;
      Data    : Ada.Streams.Stream_Element_Array (1 .. 10);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : String (1 .. 16);
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Result'Length);
      for Buf'Address use Result'Address;
      pragma Import (Ada, Buf);
   begin
      --  Encode the integer to LEB128 in the data buffer.
      Encode_LEB128 (Into => Data,
                     Pos  => Data'First,
                     Val  => Value,
                     Last => Last);

      --  Encode the data buffer in base64url.
      E.Set_URL_Mode (True);
      E.Transform (Data    => Data (Data'First .. Last),
                   Into    => Buf,
                   Last    => Last,
                   Encoded => Encoded);

      --  Strip the '=' or '==' at end of base64url.
      if Result (Positive (Last)) /= '=' then
         return Result (Result'First .. Positive (Last));
      elsif Result (Positive (Last) - 1) /= '=' then
         return Result (Result'First .. Positive (Last) - 1);
      else
         return Result (Result'First .. Positive (Last) - 2);
      end if;
   end Encode;

   --  ------------------------------
   --  Decode the base64url string and then the LEB128 integer.
   --  Raise the Encoding_Error if the string is invalid and cannot be decoded.
   --  ------------------------------
   function Decode (Value : in String) return Interfaces.Unsigned_64 is
      D       : Decoder;
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      R       : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : Interfaces.Unsigned_64;
      End_Pos : constant Ada.Streams.Stream_Element_Offset
        := Value'Length + ((4 - (Value'Length mod 4)) mod 4);
   begin
      Util.Streams.Copy (Into => Buf (1 .. Value'Length), From => Value);

      --  Set back the '=' for the base64url (pad to multiple of 4.
      Buf (Value'Length + 1) := Character'Pos ('=');
      Buf (Value'Length + 2) := Character'Pos ('=');

      --  Decode using base64url
      D.Set_URL_Mode (True);
      D.Transform (Data    => Buf (Buf'First .. End_Pos),
                   Into    => R,
                   Last    => Last,
                   Encoded => Encoded);
      if Encoded /= End_Pos then
         raise Encoding_Error with "Input string is too short";
      end if;

      --  Decode the LEB128 number.
      Decode_LEB128 (From => R (R'First .. Last),
                     Pos  => R'First,
                     Val  => Result,
                     Last => Encoded);

      --  Check that everything was decoded.
      if Last + 1 /= Encoded then
         raise Encoding_Error with "Input string contains garbage at the end";
      end if;
      return Result;
   end Decode;

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base64 output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Unsigned_8;

      Alphabet : constant Alphabet_Access := E.Alphabet;

   begin
      while I <= Data'Last loop
         if Pos + 4 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Encode the first byte, add padding if necessary.
         C1 := Unsigned_8 (Data (I));
         Into (Pos) := Alphabet (Shift_Right (C1, 2));
         if I = Data'Last then
            Into (Pos + 1) := Alphabet (Shift_Left (C1 and 3, 4));
            Into (Pos + 2) := Character'Pos ('=');
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the second byte, add padding if necessary.
         C2 := Unsigned_8 (Data (I + 1));
         Into (Pos + 1) := Alphabet (Shift_Left (C1 and 16#03#, 4) or Shift_Right (C2, 4));
         if I = Data'Last - 1 then
            Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2));
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the third byte
         C1 := Unsigned_8 (Data (I + 2));
         Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2) or Shift_Right (C1, 6));
         Into (Pos + 3) := Alphabet (C1 and 16#03F#);
         Pos := Pos + 4;
         I   := I + 3;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Alphabet := BASE64_URL_ALPHABET'Access;
      else
         E.Alphabet := BASE64_ALPHABET'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Encoder return Transformer_Access is
   begin
      return new Encoder '(Alphabet => BASE64_URL_ALPHABET'Access);
   end Create_URL_Encoder;

   --  ------------------------------
   --  Decodes the base64 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      use Ada.Streams;

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Ada.Streams.Stream_Element;
      Val1, Val2 : Unsigned_8;

      Values : constant Alphabet_Values_Access := E.Values;

   begin
      while I <= Data'Last loop
         if Pos + 3 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Decode the first two bytes to produce the first output byte
         C1 := Data (I);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
         end if;

         C2 := Data (I + 1);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
         end if;

         Into (Pos) := Stream_Element (Shift_Left (Val1, 2) or Shift_Right (Val2, 4));

         if I + 2 > Data'Last then
            Encoded := I + 1;
            Last    := Pos;
            return;
         end if;

         --  Decode the next byte
         C1 := Data (I + 2);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            if C1 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos;
            return;
         end if;

         Into (Pos + 1) := Stream_Element (Shift_Left (Val2, 4) or Shift_Right (Val1, 2));

         if I + 3 > Data'Last then
            Encoded := I + 2;
            Last    := Pos + 1;
            return;
         end if;

         C2 := Data (I + 3);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            if C2 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos + 1;
            return;
         end if;

         Into (Pos + 2) := Stream_Element (Shift_Left (Val1, 6) or Val2);
         Pos := Pos + 3;
         I   := I + 4;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Values := BASE64_URL_VALUES'Access;
      else
         E.Values := BASE64_VALUES'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Decoder return Transformer_Access is
   begin
      return new Decoder '(Values => BASE64_URL_VALUES'Access);
   end Create_URL_Decoder;

end Util.Encoders.Base64;

Implement the Encode and Decode function to encode in LEB128+base64url an integer


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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            First := Elements'First;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Fix dequeue in the Clean_On_Dequeue instantiation mode