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

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

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

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

Declare the Write_Enum_Entity for enum image value serialization


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

--  === Link Renderer ===
--  The <tt>Wiki.Render.Links</tt> package defines the <tt>Link_Renderer</tt> interface used
--  for the rendering of links and images.  The interface allows to customize the generated
--  links and image source for the final HTML.
--
package Wiki.Render.Links is

   pragma Preelaborate;

   type Link_Renderer is limited interface;
   type Link_Renderer_Access is access all Link_Renderer'Class;

   --  Get the image link that must be rendered from the wiki image link.
   procedure Make_Image_Link (Renderer : in out Link_Renderer;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Wiki.Strings.UString;
                              Width    : out Natural;
                              Height   : out Natural) is abstract;

   --  Get the page link that must be rendered from the wiki page link.
   procedure Make_Page_Link (Renderer : in out Link_Renderer;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Wiki.Strings.UString;
                             Exists   : out Boolean) is abstract;

   type Default_Link_Renderer is new Link_Renderer with null record;

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in out Default_Link_Renderer;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Wiki.Strings.UString;
                              Width    : out Natural;
                              Height   : out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in out Default_Link_Renderer;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Wiki.Strings.UString;
                             Exists   : out Boolean);

end Wiki.Render.Links;

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

--  === Link Renderer ===
--  The <tt>Wiki.Render.Links</tt> package defines the <tt>Link_Renderer</tt> interface used
--  for the rendering of links and images.  The interface allows to customize the generated
--  links and image source for the final HTML.
--
package Wiki.Render.Links is

   pragma Preelaborate;

   type Link_Renderer is limited interface;
   type Link_Renderer_Access is access all Link_Renderer'Class;

   --  Get the image link that must be rendered from the wiki image link.
   procedure Make_Image_Link (Renderer : in out Link_Renderer;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Wiki.Strings.UString;
                              Width    : in out Natural;
                              Height   : in out Natural) is abstract;

   --  Get the page link that must be rendered from the wiki page link.
   procedure Make_Page_Link (Renderer : in out Link_Renderer;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Wiki.Strings.UString;
                             Exists   : out Boolean) is abstract;

   type Default_Link_Renderer is new Link_Renderer with null record;

   --  Get the image link that must be rendered from the wiki image link.
   overriding
   procedure Make_Image_Link (Renderer : in out Default_Link_Renderer;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Wiki.Strings.UString;
                              Width    : in out Natural;
                              Height   : in out Natural);

   --  Get the page link that must be rendered from the wiki page link.
   overriding
   procedure Make_Page_Link (Renderer : in out Default_Link_Renderer;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Wiki.Strings.UString;
                             Exists   : out Boolean);

end Wiki.Render.Links;

Change the Make_Image_Link width and height parameters as in out. Before the call, the width/height represent the expected size and upon result they represent the final image size (when known and after scaling)


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

--  == Writer interfaces ==
--  The <tt>Wiki.Writers</tt> package defines the interfaces used by the renderer to write
--  their outputs.
--
--  The <tt>Input_Stream</tt> interface defines the interface that must be implemented to
--  read the source Wiki content.  The <tt>Read</tt> procedure is called by the parser
--  repeatedly while scanning the Wiki content.
package Wiki.Streams.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   type Html_Output_Stream_Type is limited interface and Output_Stream;
   type Html_Output_Stream_Access is access all Html_Output_Stream_Type'Class;

   --  Write an XML element using the given name and with the content.
   --  This is similar to calling Start_Element, Write_Text
   --  and End_Element.
   procedure Write_Wide_Element (Writer  : in out Html_Writer_Type;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Wide_Attribute (Writer  : in out Html_Writer_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Wide_Attribute (Writer  : in out Html_Writer_Type;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is abstract;

   --  Start an XML element with the given name.
   procedure Start_Element (Writer : in out Html_Writer_Type;
                            Name   : in String) is abstract;

   --  Closes an XML element of the given name.
   procedure End_Element (Writer : in out Html_Writer_Type;
                          Name   : in String) is abstract;

   --  Write a text escaping any character as necessary.
   procedure Write_Wide_Text (Writer  : in out Html_Writer_Type;
                              Content : in Unbounded_Wide_Wide_String) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Attribute (Writer  : in out Html_Writer_Type'Class;
                              Name    : in String;
                              Content : in String);

end Wiki.Streams.Html;

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

--  == Writer interfaces ==
--  The <tt>Wiki.Writers</tt> package defines the interfaces used by the renderer to write
--  their outputs.
--
--  The <tt>Input_Stream</tt> interface defines the interface that must be implemented to
--  read the source Wiki content.  The <tt>Read</tt> procedure is called by the parser
--  repeatedly while scanning the Wiki content.
package Wiki.Streams.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   type Html_Output_Stream_Type is limited interface and Output_Stream;
   type Html_Output_Stream_Access is access all Html_Output_Stream_Type'Class;

   --  Write an XML element using the given name and with the content.
   --  This is similar to calling Start_Element, Write_Text
   --  and End_Element.
   procedure Write_Wide_Element (Writer  : in out Html_Output_Stream_Type;
                                 Name    : in String;
                                 Content : in Wiki.Strings.WString) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Wide_Attribute (Writer  : in out Html_Output_Stream_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Wide_Attribute (Writer  : in out Html_Output_Stream_Type;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is abstract;

   --  Start an XML element with the given name.
   procedure Start_Element (Writer : in out Html_Output_Stream_Type;
                            Name   : in String) is abstract;

   --  Closes an XML element of the given name.
   procedure End_Element (Writer : in out Html_Output_Stream_Type;
                          Name   : in String) is abstract;

   --  Write a text escaping any character as necessary.
   procedure Write_Wide_Text (Writer  : in out Html_Output_Stream_Type;
                              Content : in Wiki.Strings.WString) is abstract;

   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   procedure Write_Attribute (Writer  : in out Html_Output_Stream_Type'Class;
                              Name    : in String;
                              Content : in String);

end Wiki.Streams.Html;

Use Html_Output_Stream_Type for interface operations


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with Util.Strings;
with Util.Strings.Transforms;

with AUnit.Time_Measure;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use type AUnit.Message_String;
   use type AUnit.Time_Measure.Time;
   use Ada.Text_IO;

   procedure Print_Summary (R : in out Result'Class);

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  T    : in AUnit.Time_Measure.Time);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   procedure Put (File : in Ada.Text_IO.File_Type;
                  T    : in AUnit.Time_Measure.Time) is
      use Ada.Calendar;

      D   : constant Duration := T.Stop - T.Start;
      S   : constant String   := Duration'Image (D);
      Pos : Natural := S'Last;
   begin
      while Pos > S'First and S (Pos) = '0' loop
         Pos := Pos - 1;
      end loop;
      if D >= 0.0 then
         Put (File, S (S'First + 1 .. Pos));
      else
         Put (File, S (S'First .. Pos));
      end if;
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine : XML_Reporter;
                     R      : in out Result'Class)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   procedure Print_Summary (R : in out Result'Class) is
      S_Count : constant Integer := Integer (Success_Count (R));
      F_Count : constant Integer := Integer (Failure_Count (R));
      E_Count : constant Integer := Integer (Error_Count (R));
   begin
      New_Line;
      Put ("Total Tests Run:   ");
      Put (Util.Strings.Image (Integer (Test_Count (R))));
      New_Line;
      Put ("Successful Tests:  ");
      Put (Util.Strings.Image (S_Count));
      New_Line;
      Put ("Failed Assertions: ");
      Put (Util.Strings.Image (F_Count));
      New_Line;
      Put ("Unexpected Errors: ");
      Put (Util.Strings.Image (E_Count));
      New_Line;
   end Print_Summary;

   ------------
   -- Report --
   ------------
   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);
   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         Put (File, " elapsed='");
         Put (File, Elapsed (R));
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Print_Summary (R);

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      use Util.Strings.Transforms;
      use type Ada.Calendar.Time;

      Is_Assert : Boolean;
   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         Put (File, " elapsed='");
         Put (File, Test.Elapsed);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Escape_Xml (Test.Test_Name.all));

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Escape_Xml (Test.Routine_Name.all));
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Escape_Xml (Test.Failure.Message.all));
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Escape_Xml (Test.Failure.Source_Name.all));
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Escape_Xml (Test.Error.Exception_Message.all));
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Escape_Xml (Test.Error.Traceback.all));
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                   A U N I T . R E P O R T E R . X M L                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--                       Copyright (C) 2000-2009, AdaCore                   --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT is maintained by AdaCore (http://www.adacore.com)                   --
--                                                                          --
------------------------------------------------------------------------------

with Util.Strings;
with Util.Strings.Transforms;

with AUnit.Time_Measure;

--  Very simple reporter to console
package body Util.Tests.Reporter is

   use AUnit.Test_Results;
   use type AUnit.Message_String;
   use type AUnit.Time_Measure.Time;
   use Ada.Text_IO;

   procedure Print_Summary (R : in out Result'Class);

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List);
   --  List failed assertions

--     procedure Put_Measure is new Gen_Put_Measure;
   --  Output elapsed time

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result);
   --  Report a single assertion failure or unexpected exception

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  T    : in AUnit.Time_Measure.Time);

   procedure Put (File : in Ada.Text_IO.File_Type;
                  I    : in Integer) is
   begin
      Ada.Text_IO.Put (File, Util.Strings.Image (I));
   end Put;

   procedure Put (File : in Ada.Text_IO.File_Type;
                  T    : in AUnit.Time_Measure.Time) is
      use Ada.Calendar;

      D   : constant Duration := T.Stop - T.Start;
      S   : constant String   := Duration'Image (D);
      Pos : Natural := S'Last;
   begin
      while Pos > S'First and S (Pos) = '0' loop
         Pos := Pos - 1;
      end loop;
      if D >= 0.0 then
         Put (File, S (S'First + 1 .. Pos));
      else
         Put (File, S (S'First .. Pos));
      end if;
   end Put;

   ----------------------
   -- Dump_Result_List --
   ----------------------

   procedure Dump_Result_List (File : in Ada.Text_IO.File_Type;
                               L    : in Result_Lists.List) is

      use Result_Lists;

      C : Cursor := First (L);

   begin

      --  Note: can't use Iterate because it violates restriction
      --  No_Implicit_Dynamic_Code

      while Has_Element (C) loop
         Report_Test (File, Element (C));
         Next (C);
      end loop;
   end Dump_Result_List;

   ------------
   -- Report --
   ------------

   procedure Report (Engine  : in XML_Reporter;
                     R       : in out Result'Class;
                     Options : in AUnit.Options.AUnit_Options := AUnit.Options.Default_Options)
   is
      Output : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => Output,
                          Mode => Ada.Text_IO.Out_File,
                          Name => To_String (Engine.File));
      Engine.Report (Output, R);
      Ada.Text_IO.Close (Output);
   end Report;

   procedure Print_Summary (R : in out Result'Class) is
      S_Count : constant Integer := Integer (Success_Count (R));
      F_Count : constant Integer := Integer (Failure_Count (R));
      E_Count : constant Integer := Integer (Error_Count (R));
   begin
      New_Line;
      Put ("Total Tests Run:   ");
      Put (Util.Strings.Image (Integer (Test_Count (R))));
      New_Line;
      Put ("Successful Tests:  ");
      Put (Util.Strings.Image (S_Count));
      New_Line;
      Put ("Failed Assertions: ");
      Put (Util.Strings.Image (F_Count));
      New_Line;
      Put ("Unexpected Errors: ");
      Put (Util.Strings.Image (E_Count));
      New_Line;
   end Print_Summary;

   ------------
   -- Report --
   ------------
   procedure Report (Engine : XML_Reporter;
                     File   : in out Ada.Text_IO.File_Type;
                     R      : in out Result'Class)
   is
      pragma Unreferenced (Engine);
   begin
      Put_Line (File, "<?xml version='1.0' encoding='utf-8' ?>");
      Put      (File, "<TestRun");

      if Elapsed  (R) /= AUnit.Time_Measure.Null_Time then
         Put (File, " elapsed='");
         Put (File, Elapsed (R));
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;

      Print_Summary (R);

      Put_Line (File, "  <Statistics>");
      Put      (File, "    <Tests>");
      Put (File, Integer (Test_Count (R)));
      Put_Line (File, "</Tests>");
      Put      (File, "    <FailuresTotal>");
      Put (File, Integer (Failure_Count (R)) + Integer (Error_Count (R)));
      Put_Line (File, "</FailuresTotal>");
      Put      (File, "    <Failures>");
      Put (File, Integer (Failure_Count (R)));
      Put_Line (File, "</Failures>");
      Put      (File, "    <Errors>");
      Put (File, Integer (Error_Count (R)));
      Put_Line (File, "</Errors>");
      Put_Line (File, "  </Statistics>");

      declare
         S : Result_Lists.List;
      begin
         Put_Line (File, "  <SuccessfulTests>");
         Successes (R, S);
         Dump_Result_List (File, S);
         Put_Line (File, "  </SuccessfulTests>");
      end;

      Put_Line (File, "  <FailedTests>");
      declare
         F : Result_Lists.List;
      begin
         Failures (R, F);
         Dump_Result_List (File, F);
      end;

      declare
         E : Result_Lists.List;
      begin
         Errors (R, E);
         Dump_Result_List (File, E);
      end;
      Put_Line (File, "  </FailedTests>");

      Put_Line (File, "</TestRun>");
   end Report;

   ------------------
   -- Report_Error --
   ------------------

   procedure Report_Test (File : in Ada.Text_IO.File_Type;
                          Test : in Test_Result) is

      use Util.Strings.Transforms;
      use type Ada.Calendar.Time;

      Is_Assert : Boolean;
   begin
      Put (File, "    <Test");
      if Test.Elapsed /= AUnit.Time_Measure.Null_Time then
         Put (File, " elapsed='");
         Put (File, Test.Elapsed);
         Put_Line (File, "'>");
      else
         Put_Line (File, ">");
      end if;
      Put      (File, "      <Name>");
      Put      (File, Escape_Xml (Test.Test_Name.all));

      if Test.Routine_Name /= null then
         Put (File, " : ");
         Put (File, Escape_Xml (Test.Routine_Name.all));
      end if;

      Put_Line (File, "</Name>");

      if Test.Failure /= null or else Test.Error /= null then
         if Test.Failure /= null then
            Is_Assert := True;
         else
            Is_Assert := False;
         end if;

         Put      (File, "      <FailureType>");

         if Is_Assert then
            Put   (File, "Assertion");
         else
            Put   (File, "Error");
         end if;

         Put_Line (File, "</FailureType>");
         Put      (File, "      <Message>");
         if Is_Assert then
            Put   (File, Escape_Xml (Test.Failure.Message.all));
         else
            Put   (File, Test.Error.Exception_Name.all);
         end if;
         Put_Line (File, "</Message>");

         if Is_Assert then
            Put_Line (File, "      <Location>");
            Put      (File, "        <File>");
            Put      (File, Escape_Xml (Test.Failure.Source_Name.all));
            Put_Line (File, "</File>");
            Put      (File, "        <Line>");
            Put      (File, Test.Failure.Line);
            Put_Line (File, "</Line>");
            Put_Line (File, "      </Location>");

         else
            Put_Line (File, "      <Exception>");
            Put      (File, "      <Message>");
            Put      (File, Test.Error.Exception_Name.all);
            Put_Line (File, "</Message>");

            if Test.Error.Exception_Message /= null then
               Put      (File, "      <Information>");
               Put      (File, Escape_Xml (Test.Error.Exception_Message.all));
               Put_Line (File, "</Information>");
            end if;

            if Test.Error.Traceback /= null then
               Put      (File, "      <Traceback>");
               Put      (File, Escape_Xml (Test.Error.Traceback.all));
               Put_Line (File, "</Traceback>");
            end if;

            Put_Line (File, "      </Exception>");
         end if;
      end if;

      Put_Line (File, "    </Test>");
   end Report_Test;

end Util.Tests.Reporter;

Fix compilation with AUnit 2014

Fix compilation with AUnit 2014


with
     ada.Characters.latin_1,
     ada.Characters.handling,
     ada.Strings.fixed,
     ada.Strings.Maps.Constants;

--  with ada.text_IO; use ada.Text_IO;

package body lace.text.Cursor
is
   use ada.Strings;

   Integer_Numerals : constant maps.character_Set := maps.to_Set ("+-0123456789");
   Float_Numerals   : constant maps.character_Set := maps.to_Set ("+-0123456789.");

   --------
   -- Forge
   --

   function First (of_Text : access constant Text.item) return Cursor.item
   is
      the_Cursor : constant Cursor.item := (of_Text.all'unchecked_Access, 1);
   begin
      return the_Cursor;
   end First;

   -------------
   -- Attributes
   --

   function at_End (Self : in Item) return Boolean
   is
   begin
      return Self.Current = 0;
   end at_End;

   function has_Element (Self : in Item) return Boolean
   is
   begin
      return not at_End (Self)
        and      Self.Current <= Self.Target.Length;
   end has_Element;

   procedure advance (Self : in out Item;   Delimiter      : in String  := " ";
                                            Repeat         : in Natural := 0;
                                            skip_Delimiter : in Boolean := True;
                                            match_Case     : in Boolean := True)
   is
   begin
      for Count in 1 .. Repeat + 1
      loop
         declare
            use ada.Characters.handling;
            delimiter_Position : Natural;
         begin
            if match_Case
            then
               delimiter_Position := fixed.Index (Self.Target.Data (1 .. Self.Target.Length),
                                                  Delimiter,
                                                  From => Self.Current);
            else
               delimiter_Position := fixed.Index (to_Lower (Self.Target.Data (1 .. Self.Target.Length)),
                                                  to_Lower (Delimiter),
                                                  From => Self.Current);
            end if;

            if delimiter_Position = 0
            then
               Self.Current := 0;
               return;
            else
               if skip_Delimiter
               then
                  Self.Current := delimiter_Position + Delimiter'Length;

               elsif Count = Repeat + 1
               then
                  Self.Current := delimiter_Position;

               else
                  Self.Current := delimiter_Position + Delimiter'Length - 1;
               end if;
            end if;
         end;
      end loop;

   exception
      when constraint_Error =>
         raise at_end_Error;
   end advance;

   procedure skip_White (Self : in out Item)
   is
   begin
      while      has_Element (Self)
        and then (    Self.Target.Data (Self.Current) = ' '
                  or  Self.Target.Data (Self.Current) = ada.Characters.Latin_1.LF
                  or  Self.Target.Data (Self.Current) = ada.Characters.Latin_1.HT)
      loop
         Self.Current := Self.Current + 1;
      end loop;
   end skip_White;

   procedure skip_Line (Self : in out Item)
   is
      Line : String := next_Line (Self) with Unreferenced;
   begin
      null;
   end skip_Line;

   function next_Token (Self      : in out Item;
                        Delimiter : in     Character := ' ';
                        Trim      : in     Boolean   := False) return String
   is
   begin
      return next_Token (Self, "" & Delimiter, Trim);
   end next_Token;

   function next_Token (Self : in out item;   Delimiter  : in String;
                                              match_Case : in Boolean := True;
                                              Trim       : in Boolean := False) return String
   is
      use ada.Characters.handling;
   begin
      if at_End (Self)
      then
         raise at_end_Error;
      end if;

      declare
         use ada.Strings.fixed,
             ada.Strings.Maps.Constants;
         delimiter_Position : constant Natural := (if match_Case then Index (Self.Target.Data (Self.Current .. Self.Target.Length),           Delimiter,  from => Self.Current)
                                                                 else Index (Self.Target.Data (Self.Current .. Self.Target.Length), to_Lower (Delimiter), from => Self.Current,
                                                                                mapping => lower_case_Map));
      begin
         --  put_Line ("delimiter_Position" & delimiter_Position'Image);

         if delimiter_Position = 0
         then
            return the_Token : constant String := (if Trim then fixed.Trim (Self.Target.Data (Self.Current .. Self.Target.Length), Both)
                                                           else             Self.Target.Data (Self.Current .. Self.Target.Length))
            do
               Self.Current := 0;
            end return;
         end if;

         return the_Token : constant String := (if Trim then fixed.Trim (Self.Target.Data (Self.Current .. delimiter_Position - 1), Both)
                                                        else             Self.Target.Data (Self.Current .. delimiter_Position - 1))
         do
            Self.Current := delimiter_Position + Delimiter'Length;
         end return;
      end;
   end next_Token;

   function next_Line (Self : in out Item;   Trim : in Boolean := False) return String
   is
      use ada.Characters;
      Token : constant String := next_Token (Self, Delimiter => latin_1.LF,
                                                   Trim      => Trim);
      Pad   : constant String := Token; --(if Token (Token'Last) = latin_1.CR then Token (Token'First .. Token'Last - 1)
                                          --                           else Token);
   begin
      if Trim then return fixed.Trim (Pad, Both);
              else return Pad;
      end if;
   end next_Line;

   procedure skip_Token (Self : in out Item;   Delimiter  : in String    := " ";
                                               match_Case : in Boolean   := True)
   is
      ignored_Token : String := Self.next_Token (Delimiter, match_Case);
   begin
      null;
   end skip_Token;

   function get_Integer (Self : in out Item) return Integer
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, integer_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return Integer'Value (Text (First .. Last));
   end get_Integer;

   function get_Integer (Self : in out Item) return long_Integer
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, integer_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return long_Integer'Value (Text (First .. Last));
   end get_Integer;

   function get_Real (Self : in out Item) return long_Float
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, float_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return long_Float'Value (Text (First .. Last));
   end get_Real;

   function Length (Self : in Item) return Natural
   is
   begin
      return Self.Target.Length - Self.Current + 1;
   end Length;

   function peek (Self : in Item;   Length : in Natural := Remaining) return String
   is
      Last : constant Natural := (if Length = Natural'Last then Self.Target.Length
                                                           else Self.Current + Length - 1);
   begin
      if at_End (Self)
      then
         return "";
      end if;

      return Self.Target.Data (Self.Current .. Last);
   end peek;

   function peek_Line (Self : in Item) return String
   is
      C : Cursor.item := Self;
   begin
      return next_Line (C);
   end peek_Line;

end lace.text.Cursor;

with
     ada.Characters.latin_1,
     ada.Characters.handling,
     ada.Strings.fixed,
     ada.Strings.Maps.Constants;

--  with ada.text_IO; use ada.Text_IO;

package body lace.text.Cursor
is
   use ada.Strings;

   Integer_Numerals : constant maps.character_Set := maps.to_Set ("+-0123456789");
   Float_Numerals   : constant maps.character_Set := maps.to_Set ("+-0123456789.");

   --------
   -- Forge
   --

   function First (of_Text : access constant Text.item) return Cursor.item
   is
      the_Cursor : constant Cursor.item := (of_Text.all'unchecked_Access, 1);
   begin
      return the_Cursor;
   end First;

   -------------
   -- Attributes
   --

   function at_End (Self : in Item) return Boolean
   is
   begin
      return Self.Current = 0;
   end at_End;

   function has_Element (Self : in Item) return Boolean
   is
   begin
      return not at_End (Self)
        and      Self.Current <= Self.Target.Length;
   end has_Element;

   procedure advance (Self : in out Item;   Delimiter      : in String  := " ";
                                            Repeat         : in Natural := 0;
                                            skip_Delimiter : in Boolean := True;
                                            match_Case     : in Boolean := True)
   is
   begin
      for Count in 1 .. Repeat + 1
      loop
         declare
            use ada.Characters.handling;
            delimiter_Position : Natural;
         begin
            if match_Case
            then
               delimiter_Position := fixed.Index (Self.Target.Data (1 .. Self.Target.Length),
                                                  Delimiter,
                                                  From => Self.Current);
            else
               delimiter_Position := fixed.Index (to_Lower (Self.Target.Data (1 .. Self.Target.Length)),
                                                  to_Lower (Delimiter),
                                                  From => Self.Current);
            end if;

            if delimiter_Position = 0
            then
               Self.Current := 0;
               return;
            else
               if skip_Delimiter
               then
                  Self.Current := delimiter_Position + Delimiter'Length;

               elsif Count = Repeat + 1
               then
                  Self.Current := delimiter_Position;

               else
                  Self.Current := delimiter_Position + Delimiter'Length - 1;
               end if;
            end if;
         end;
      end loop;

   exception
      when constraint_Error =>
         raise at_end_Error;
   end advance;

   procedure skip_White (Self : in out Item)
   is
   begin
      while      has_Element (Self)
        and then (    Self.Target.Data (Self.Current) = ' '
                  or  Self.Target.Data (Self.Current) = ada.Characters.Latin_1.LF
                  or  Self.Target.Data (Self.Current) = ada.Characters.Latin_1.HT)
      loop
         Self.Current := Self.Current + 1;
      end loop;
   end skip_White;

   procedure skip_Line (Self : in out Item)
   is
      Line : String := next_Line (Self) with Unreferenced;
   begin
      null;
   end skip_Line;

   function next_Token (Self      : in out Item;
                        Delimiter : in     Character := ' ';
                        Trim      : in     Boolean   := False) return String
   is
   begin
      return next_Token (Self, "" & Delimiter, Trim);
   end next_Token;

   function next_Token (Self : in out item;   Delimiter  : in String;
                                              match_Case : in Boolean := True;
                                              Trim       : in Boolean := False) return String
   is
      use ada.Characters.handling;
   begin
      if at_End (Self)
      then
         raise at_end_Error;
      end if;

      declare
         function get_String return String
         is
            use ada.Strings.fixed,
                ada.Strings.Maps.Constants;
            delimiter_Position : constant Natural := (if match_Case then Index (Self.Target.Data (Self.Current .. Self.Target.Length),           Delimiter,  from => Self.Current)
                                                                    else Index (Self.Target.Data (Self.Current .. Self.Target.Length), to_Lower (Delimiter), from => Self.Current,
                                                                                mapping => lower_case_Map));
         begin
            if delimiter_Position = 0
            then
               return the_Token : constant String := (if Trim then fixed.Trim (Self.Target.Data (Self.Current .. Self.Target.Length), Both)
                                                              else             Self.Target.Data (Self.Current .. Self.Target.Length))
               do
                  Self.Current := 0;
               end return;
            end if;

            return the_Token : constant String := (if Trim then fixed.Trim (Self.Target.Data (Self.Current .. delimiter_Position - 1), Both)
                                                           else             Self.Target.Data (Self.Current .. delimiter_Position - 1))
            do
               Self.Current := delimiter_Position + Delimiter'Length;
            end return;
         end get_String;

         unslid_String : constant String                             := get_String;
         slid_String   : constant String (1 .. unslid_String'Length) := unslid_String;

      begin
         return slid_String;
      end;
   end next_Token;

   function next_Line (Self : in out Item;   Trim : in Boolean := False) return String
   is
      use ada.Characters;
      Token : constant String := next_Token (Self, Delimiter => latin_1.LF,
                                                   Trim      => Trim);
      Pad   : constant String := Token; --(if Token (Token'Last) = latin_1.CR then Token (Token'First .. Token'Last - 1)
                                          --                           else Token);
   begin
      if Trim then return fixed.Trim (Pad, Both);
              else return Pad;
      end if;
   end next_Line;

   procedure skip_Token (Self : in out Item;   Delimiter  : in String    := " ";
                                               match_Case : in Boolean   := True)
   is
      ignored_Token : String := Self.next_Token (Delimiter, match_Case);
   begin
      null;
   end skip_Token;

   function get_Integer (Self : in out Item) return Integer
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, integer_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return Integer'Value (Text (First .. Last));
   end get_Integer;

   function get_Integer (Self : in out Item) return long_Integer
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, integer_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return long_Integer'Value (Text (First .. Last));
   end get_Integer;

   function get_Real (Self : in out Item) return long_Float
   is
      use ada.Strings.fixed;

      Text  : String (1 .. Self.Length);
      First : Positive;
      Last  : Natural;
   begin
      Text := Self.Target.Data (Self.Current .. Self.Target.Length);
      find_Token (Text, float_Numerals, Inside, First, Last);

      if Last = 0 then
         raise No_Data_Error;
      end if;

      Self.Current := Self.Current + Last;

      return long_Float'Value (Text (First .. Last));
   end get_Real;

   function Length (Self : in Item) return Natural
   is
   begin
      return Self.Target.Length - Self.Current + 1;
   end Length;

   function peek (Self : in Item;   Length : in Natural := Remaining) return String
   is
      Last : Natural := (if Length = Remaining then Self.Target.Length
                                               else Self.Current + Length - 1);
   begin
      if at_End (Self)
      then
         return "";
      end if;

      Last := Natural'Min (Last,
                           Self.Target.Length);

      return Self.Target.Data (Self.Current .. Last);
   end peek;

   function peek_Line (Self : in Item) return String
   is
      C : Cursor.item := Self;
   begin
      return next_Line (C);
   end peek_Line;

end lace.text.Cursor;

Fix bug in the 'peek' function.

lace.text.cursor: Fix bug in the 'peek' function.


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

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

end MAT.Expressions;

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

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

end MAT.Expressions;

Implement the Create_Inside operation

Implement the Create_Inside operation


--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Long_Long_Integer;
   subtype ino_t is Long_Long_Integer;
   subtype off_t is Long_Long_Integer;
   subtype blksize_t is Long_Long_Integer;
   subtype blkcnt_t is Long_Long_Integer;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Long_Long_Integer;
   subtype mode_t is Interfaces.C.unsigned;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Long_Long_Integer;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Long_Long_Integer;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   STAT_NAME  : constant String := "stat";
   FSTAT_NAME : constant String := "fstat";
   type Stat_Type is record
      st_dev     : dev_t;
      st_ino     : ino_t;
      st_nlink   : nlink_t;
      st_mode    : mode_t;
      st_uid     : uid_t;
      st_gid     : gid_t;
      pad1_0     : Interfaces.C.unsigned;
      st_rdev    : dev_t;
      st_size    : off_t;
      st_blksize : blksize_t;
      st_blocks  : blkcnt_t;
      st_atim    : Timespec;
      st_mtim    : Timespec;
      st_ctim    : Timespec;
      pad5    : Interfaces.C.unsigned_long;
      pad6    : Interfaces.C.unsigned_long;
      pad7    : Interfaces.C.unsigned_long;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

--  Generated by utildgen.c from system includes
with Interfaces.C;
package Util.Systems.Types is

   subtype dev_t is Long_Long_Integer;
   subtype ino_t is Long_Long_Integer;
   subtype off_t is Long_Long_Integer;
   subtype blksize_t is Long_Long_Integer;
   subtype blkcnt_t is Long_Long_Integer;
   subtype uid_t is Interfaces.C.unsigned;
   subtype gid_t is Interfaces.C.unsigned;
   subtype nlink_t is Long_Long_Integer;
   subtype mode_t is Interfaces.C.unsigned;

   S_IFMT   : constant mode_t := 8#00170000#;
   S_IFDIR  : constant mode_t := 8#00040000#;
   S_IFCHR  : constant mode_t := 8#00020000#;
   S_IFBLK  : constant mode_t := 8#00060000#;
   S_IFREG  : constant mode_t := 8#00100000#;
   S_IFIFO  : constant mode_t := 8#00010000#;
   S_IFLNK  : constant mode_t := 8#00120000#;
   S_IFSOCK : constant mode_t := 8#00140000#;
   S_ISUID  : constant mode_t := 8#00004000#;
   S_ISGID  : constant mode_t := 8#00002000#;
   S_IREAD  : constant mode_t := 8#00000400#;
   S_IWRITE : constant mode_t := 8#00000200#;
   S_IEXEC  : constant mode_t := 8#00000100#;

   type File_Type is new Interfaces.C.int;
   subtype Time_Type is Long_Long_Integer;

   type Timespec is record
      tv_sec  : Time_Type;
      tv_nsec : Long_Long_Integer;
   end record;
   pragma Convention (C_Pass_By_Copy, Timespec);

   type Seek_Mode is (SEEK_SET, SEEK_CUR, SEEK_END);
   for Seek_Mode use (SEEK_SET => 0, SEEK_CUR => 1, SEEK_END => 2);

   STAT_NAME  : constant String := "stat";
   FSTAT_NAME : constant String := "fstat";
   LSTAT_NAME : constant String := "lstat";
   type Stat_Type is record
      st_dev     : dev_t;
      st_ino     : ino_t;
      st_nlink   : nlink_t;
      st_mode    : mode_t;
      st_uid     : uid_t;
      st_gid     : gid_t;
      pad1_0     : Interfaces.C.unsigned;
      st_rdev    : dev_t;
      st_size    : off_t;
      st_blksize : blksize_t;
      st_blocks  : blkcnt_t;
      st_atim    : Timespec;
      st_mtim    : Timespec;
      st_ctim    : Timespec;
      pad5    : Interfaces.C.unsigned_long;
      pad6    : Interfaces.C.unsigned_long;
      pad7    : Interfaces.C.unsigned_long;
   end record;
   pragma Convention (C_Pass_By_Copy, Stat_Type);

end Util.Systems.Types;

Add LSTAT_NAME for lstat(2)

Add LSTAT_NAME for lstat(2)


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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Permission_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

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

with Util.Tests;
with Util.Log.Loggers;

with AWA.Applications;
with AWA.Tests;
with AWA.Users.Modules;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Tests.Helpers.Users is

   use AWA.Users.Services;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Tests.Helpers.Users");

   --  ------------------------------
   --  Initialize the service context.
   --  ------------------------------
   procedure Initialize (Principal : in out Test_User) is
   begin
      --  Setup the service context.
      Principal.Context.Set_Context (AWA.Tests.Get_Application, null);

      if Principal.Manager = null then
         Principal.Manager := AWA.Users.Modules.Get_User_Manager;
         if Principal.Manager = null then
            Log.Error ("There is no User_Manager in the application.");
         end if;
      end if;
   end Initialize;

   --  ------------------------------
   --  Create a test user associated with the given email address.
   --  Get an open session for that user.  If the user already exists, no error is reported.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User;
                          Email     : in String) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the user
      Query.Set_Join ("inner join email e on e.user_id = o.id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Principal.User.Find (DB, Query, Found);
      if not Found then
         Principal.User.Set_First_Name ("Joe");
         Principal.User.Set_Last_Name ("Pot");
         Principal.User.Set_Password ("admin");
         Principal.Email.Set_Email (Email);
         Principal.Manager.Create_User (Principal.User, Principal.Email);

         Find_Access_Key (Principal, Email, Key);

         --  Run the verification and get the user and its session
         Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                        Principal.Principal);
      else
         Principal.Manager.Authenticate (Email     => Email,
                                         Password  => "admin",
                                         IpAddr    => "192.168.1.1",
                                         Principal => Principal.Principal);
      end if;
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Create a test user for a new test and get an open session.
   --  ------------------------------
   procedure Create_User (Principal : in out Test_User) is
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
   begin
      Initialize (Principal);
      Principal.User.Set_First_Name ("Joe");
      Principal.User.Set_Last_Name ("Pot");
      Principal.User.Set_Password ("admin");
      Principal.Email.Set_Email (Email);
      Principal.Manager.Create_User (Principal.User, Principal.Email);

      Find_Access_Key (Principal, Email, Key);

      --  Run the verification and get the user and its session
      Principal.Manager.Verify_User (Key.Get_Access_Key, "192.168.1.1",
                                     Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Create_User;

   --  ------------------------------
   --  Find the access key associated with a user (if any).
   --  ------------------------------
   procedure Find_Access_Key (Principal : in out Test_User;
                              Email     : in String;
                              Key       : in out AWA.Users.Models.Access_Key_Ref) is
      DB    : ADO.Sessions.Session;
      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      Initialize (Principal);

      DB := Principal.Manager.Get_Session;

      --  Find the access key
      Query.Set_Join ("inner join email e on e.user_id = o.user_id");
      Query.Set_Filter ("e.email = ?");
      Query.Bind_Param (1, Email);
      Key.Find (DB, Query, Found);
      if not Found then
         Log.Error ("Cannot find access key for email {0}", Email);
      end if;
   end Find_Access_Key;

   --  ------------------------------
   --  Login a user and create a session
   --  ------------------------------
   procedure Login (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Authenticate (Email     => Principal.Email.Get_Email,
                                      Password  => "admin",
                                      IpAddr    => "192.168.1.1",
                                      Principal => Principal.Principal);
      Principal.User    := Principal.Principal.Get_User;
      Principal.Session := Principal.Principal.Get_Session;
   end Login;

   --  ------------------------------
   --  Logout the user and closes the current session.
   --  ------------------------------
   procedure Logout (Principal : in out Test_User) is
   begin
      Initialize (Principal);
      Principal.Manager.Close_Session (Principal.Session.Get_Id, True);
   end Logout;

   --  Simulate a user login in the given service context.
   procedure Login (Context : in out AWA.Services.Contexts.Service_Context;
                    Sec_Context : in out Security.Contexts.Security_Context;
                    Email   : in String) is
      User      : Test_User;
      Principal : AWA.Users.Principals.Principal_Access;
      App       : constant AWA.Applications.Application_Access := AWA.Tests.Get_Application;
   begin
      AWA.Tests.Set_Application_Context;
      Create_User (User, Email);
      Principal := AWA.Users.Principals.Create (User.User, User.Session);
      Context.Set_Context (App, Principal);
      Sec_Context.Set_Context (Manager   => App.Get_Security_Manager,
                               Principal => Principal.all'Access);
   end Login;

   overriding
   procedure Finalize (Principal : in out Test_User) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Users.Principals.Principal'Class,
                                         Name   => AWA.Users.Principals.Principal_Access);
   begin
      Free (Principal.Principal);
   end Finalize;

end AWA.Tests.Helpers.Users;

Fix compilation

Fix compilation