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

with Sax.Exceptions;
with Sax.Locators;
with Sax.Readers;
with Sax.Attributes;
with Unicode.CES;
with Input_Sources;

with Ada.Streams;
with Ada.Strings.Unbounded;
with Util.Streams.Buffered;
with Util.Streams.Texts;
package Util.Serialize.IO.XML is

   Parse_Error : exception;

   type Parser is new Serialize.IO.Parser with private;

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

   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean);

   --  Set the XHTML reader to ignore empty lines.
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean);

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

   type Xhtml_Reader is new Sax.Readers.Reader with private;

   --  ------------------------------
   --  XML Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating an XML output stream.
   --  The stream object takes care of the XML escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Write a character on the response stream and escape that character as necessary.
   procedure Write_Escape (Stream : in out Output_Stream'Class;
                           Char   : in Wide_Wide_Character);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in Util.Beans.Objects.Object);

   --  Start a new XML object.
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current XML object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

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

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

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

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

   --  Write a XML name/value attribute.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);
   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

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

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

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

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

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

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

   --  Write a XML name/value entity (see Write_Attribute).
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Starts a XML array.
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type);

   --  Terminates a XML array.
   procedure End_Array (Stream : in out Output_Stream);

   --  Return the location where the exception was raised.
   function Get_Location (Except : Sax.Exceptions.Sax_Parse_Exception'Class)
                          return String;

private

   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator);

   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence);

   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class);

   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "");

   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader);

   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "");

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence);

   type Xhtml_Reader is new Sax.Readers.Reader with record
      Stack_Pos  : Natural := 0;
      Handler    : access Parser'Class;

      Text : Ada.Strings.Unbounded.Unbounded_String;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      --  The SAX locator to find the current file and line number.
      Locator             : Sax.Locators.Locator;
      Has_Pending_Char   : Boolean := False;
      Pending_Char       : Character;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines  : Boolean := True;
   end record;

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Close_Start : Boolean := False;
      Stream      : Util.Streams.Texts.Print_Stream_Access;
   end record;

end Util.Serialize.IO.XML;

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

with Sax.Exceptions;
with Sax.Locators;
with Sax.Readers;
with Sax.Attributes;
with Unicode.CES;
with Input_Sources;

with Ada.Streams;
with Ada.Strings.Unbounded;
with Util.Streams.Buffered;
with Util.Streams.Texts;
package Util.Serialize.IO.XML is

   Parse_Error : exception;

   type Parser is new Serialize.IO.Parser with private;

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

   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean);

   --  Set the XHTML reader to ignore empty lines.
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean);

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

   type Xhtml_Reader is new Sax.Readers.Reader with private;

   --  ------------------------------
   --  XML Output Stream
   --  ------------------------------
   --  The <b>Output_Stream</b> provides methods for creating an XML output stream.
   --  The stream object takes care of the XML escape rules.
   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with private;

   --  Set the target output stream.
   procedure Initialize (Stream : in out Output_Stream;
                         Output : in Util.Streams.Texts.Print_Stream_Access);

   --  Flush the buffer (if any) to the sink.
   overriding
   procedure Flush (Stream : in out Output_Stream);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Stream);

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Output_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Output_Stream;
                    Item   : in String);

   --  Write a character on the response stream and escape that character as necessary.
   procedure Write_Escape (Stream : in out Output_Stream'Class;
                           Char   : in Wide_Wide_Character);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_Wide_String (Stream : in out Output_Stream;
                                Value  : in Wide_Wide_String);

   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in Util.Beans.Objects.Object);

   --  Start a new XML object.
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String);

   --  Terminates the current XML object.
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String);

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

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

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

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

   --  Write a XML name/value attribute.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);
   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

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

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

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

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

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

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

   --  Write a XML name/value entity (see Write_Attribute).
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  Starts a XML array.
   overriding
   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String);

   --  Terminates a XML array.
   overriding
   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String);

   --  Return the location where the exception was raised.
   function Get_Location (Except : Sax.Exceptions.Sax_Parse_Exception'Class)
                          return String;

private

   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class);

   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator);

   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Document (Handler : in out Xhtml_Reader);

   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence);

   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class);

   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "");

   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence);

   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader);

   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader);

   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "");

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence);

   type Xhtml_Reader is new Sax.Readers.Reader with record
      Stack_Pos  : Natural := 0;
      Handler    : access Parser'Class;

      Text : Ada.Strings.Unbounded.Unbounded_String;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      --  The SAX locator to find the current file and line number.
      Locator             : Sax.Locators.Locator;
      Has_Pending_Char   : Boolean := False;
      Pending_Char       : Character;

      --  Whether white spaces can be ignored.
      Ignore_White_Spaces : Boolean := True;

      --  Whether empty lines should be ignored (when white spaces are kept).
      Ignore_Empty_Lines  : Boolean := True;
   end record;

   type Output_Stream is limited new Util.Serialize.IO.Output_Stream with record
      Close_Start : Boolean := False;
      Stream      : Util.Streams.Texts.Print_Stream_Access;
   end record;

end Util.Serialize.IO.XML;

Fix Start_Array and End_Array operation and mark them overriding


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

package body Util.Commands.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Console, Kind);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : constant Natural := Value'Last;
      Pad   : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length > Size then
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Pad := Size - Value'Length - 1;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      elsif Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end Util.Commands.Consoles.Text;

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

package body Util.Commands.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Console, Kind);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : constant Natural := Value'Last;
      Pad   : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length > Size then
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Pad := Size - Value'Length - 1;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      elsif Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      null;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end Util.Commands.Consoles.Text;

Fix header style

Fix header style


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

with Ada.Strings.Unbounded;
with EL.Expressions;
with EL.Beans.Methods.Proc_1;
with ASF.Contexts.Faces;
with ASF.Components.Base;
package ASF.Events.Actions is

   package Action_Method is
     new EL.Beans.Methods.Proc_1 (Param1_Type => Ada.Strings.Unbounded.Unbounded_String);

   --  ------------------------------
   --  Action event
   --  ------------------------------
   --  The Action_Event is posted when a method bean action must be executed
   --  as a result of a command (such as button press).  The method action must return
   --  an outcome string that indicates which view to return.
   type Action_Event is new Faces_Event with private;
   type Action_Event_Access is access all Action_Event'Class;

   --  Get the method expression to invoke
   function Get_Method (Event : in Action_Event) return EL.Expressions.Method_Expression;

   --  Post an Action_Event on the component.
   procedure Post_Event (UI     : in out Components.Base.UIComponent'Class;
                         Method : in EL.Expressions.Method_Expression);

   --  ------------------------------
   --  Action Listener
   --  ------------------------------
   --  The Action_Listener is the interface to receive the Action_Event.
   type Action_Listener is limited interface and Util.Events.Event_Listener;
   type Action_Listener_Access is access all Action_Listener'Class;

   --  Process the action associated with the action event.
   procedure Process_Action (Listener : in Action_Listener;
                             Event    : in Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class) is abstract;

private

   type Action_Event is new Faces_Event with record
      Method : EL.Expressions.Method_Expression;
   end record;

end ASF.Events.Actions;

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

with Ada.Strings.Unbounded;
with EL.Expressions;
with EL.Methods.Proc_1;
with ASF.Contexts.Faces;
with ASF.Components.Base;
package ASF.Events.Actions is

   package Action_Method is
     new EL.Methods.Proc_1 (Param1_Type => Ada.Strings.Unbounded.Unbounded_String);

   --  ------------------------------
   --  Action event
   --  ------------------------------
   --  The Action_Event is posted when a method bean action must be executed
   --  as a result of a command (such as button press).  The method action must return
   --  an outcome string that indicates which view to return.
   type Action_Event is new Faces_Event with private;
   type Action_Event_Access is access all Action_Event'Class;

   --  Get the method expression to invoke
   function Get_Method (Event : in Action_Event) return EL.Expressions.Method_Expression;

   --  Post an Action_Event on the component.
   procedure Post_Event (UI     : in out Components.Base.UIComponent'Class;
                         Method : in EL.Expressions.Method_Expression);

   --  ------------------------------
   --  Action Listener
   --  ------------------------------
   --  The Action_Listener is the interface to receive the Action_Event.
   type Action_Listener is limited interface and Util.Events.Event_Listener;
   type Action_Listener_Access is access all Action_Listener'Class;

   --  Process the action associated with the action event.
   procedure Process_Action (Listener : in Action_Listener;
                             Event    : in Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class) is abstract;

private

   type Action_Event is new Faces_Event with record
      Method : EL.Expressions.Method_Expression;
   end record;

end ASF.Events.Actions;

Fix compilation after refactoring of Ada-El and Ada-Util


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

with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.Mappers.Vector_Mapper;
with Util.Serialize.Mappers;
with Ada.Containers.Vectors;
with Util.Serialize.Contexts;
package Mapping is

   use Ada.Strings.Unbounded;

   type Property is record
      Name     : Unbounded_String;
      Value    : Unbounded_String;
   end record;

   type Address is record
      City      : Unbounded_String;
      Street    : Unbounded_String;
      Country   : Unbounded_String;
      Zip       : Natural := 0;
      Info      : Property;
   end record;

   type Person is record
      Name       : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Username   : Unbounded_String;
      Gender     : Unbounded_String;
      Link       : Unbounded_String;
      Age        : Natural := 0;
      Addr       : Address;
      Id         : Long_Long_Integer := 0;
   end record;

   type Person_Access is access all Person;

   type Person_Fields is (FIELD_FIRST_NAME, FIELD_LAST_NAME, FIELD_AGE,
                          FIELD_NAME, FIELD_USER_NAME, FIELD_GENDER,
                          FIELD_LINK, FIELD_ID);

   --  Set the name/value pair on the current object.
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object);

   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object;

   package Person_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Person,
                                               Element_Type_Access => Person_Access,
                                               Fields              => Person_Fields,
                                               Set_Member          => Set_Member);

   subtype Person_Context is Person_Mapper.Element_Data;

   package Person_Vector is
     new Ada.Containers.Vectors (Element_Type => Person,
                                 Index_Type   => Natural);

   package Person_Vector_Mapper is
     new Util.Serialize.Mappers.Vector_Mapper (Vectors        => Person_Vector,
                                               Element_Mapper => Person_Mapper);

   subtype Person_Vector_Context is Person_Vector_Mapper.Vector_Data;

   --  Get the address mapper which describes how to load an Address.
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access;

   --  Get the person mapper which describes how to load a Person.
   function Get_Person_Mapper return Person_Mapper.Mapper_Access;

   --  Get the person vector mapper which describes how to load a list of Person.
   function Get_Person_Vector_Mapper return Person_Vector_Mapper.Mapper_Access;

end Mapping;

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

with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.Mappers;
with Ada.Containers.Vectors;
package Mapping is

   use Ada.Strings.Unbounded;

   type Property is record
      Name     : Unbounded_String;
      Value    : Unbounded_String;
   end record;

   type Address is record
      City      : Unbounded_String;
      Street    : Unbounded_String;
      Country   : Unbounded_String;
      Zip       : Natural := 0;
      Info      : Property;
   end record;

   type Person is record
      Name       : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Username   : Unbounded_String;
      Gender     : Unbounded_String;
      Link       : Unbounded_String;
      Age        : Natural := 0;
      Addr       : Address;
      Id         : Long_Long_Integer := 0;
   end record;

   type Person_Access is access all Person;

   type Person_Fields is (FIELD_FIRST_NAME, FIELD_LAST_NAME, FIELD_AGE,
                          FIELD_NAME, FIELD_USER_NAME, FIELD_GENDER,
                          FIELD_LINK, FIELD_ID);

   --  Set the name/value pair on the current object.
   procedure Set_Member (P     : in out Person;
                         Field : in Person_Fields;
                         Value : in Util.Beans.Objects.Object);

   function Get_Person_Member (From  : in Person;
                               Field : in Person_Fields) return Util.Beans.Objects.Object;

   package Person_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Person,
                                               Element_Type_Access => Person_Access,
                                               Fields              => Person_Fields,
                                               Set_Member          => Set_Member);

   subtype Person_Context is Person_Mapper.Element_Data;

   package Person_Vector is
     new Ada.Containers.Vectors (Element_Type => Person,
                                 Index_Type   => Natural);

   --  Get the address mapper which describes how to load an Address.
   function Get_Address_Mapper return Util.Serialize.Mappers.Mapper_Access;

   --  Get the person mapper which describes how to load a Person.
   function Get_Person_Mapper return Person_Mapper.Mapper_Access;

end Mapping;

Remove the Person_Vector_Mapper instantiation so that we don't depend on the Vector_Mapper generic package


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

with AWA.Applications;

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
with Security.Policies.Roles;
package AWA.Permissions.Services is

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Initialize the permissions.
   procedure Start (Manager : in out Permission_Manager);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Get the role names that grant the given permission.
   function Get_Role_Names (Manager : in Permission_Manager;
                            Permission : in Security.Permissions.Permission_Index)
                            return Security.Policies.Roles.Role_Name_Array;

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

   --  Delete all the permissions for a user and on the given workspace.
   procedure Delete_Permissions (Session   : in out ADO.Sessions.Master_Session;
                                 User      : in ADO.Identifier;
                                 Workspace : in ADO.Identifier);

private

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App   : AWA.Applications.Application_Access;
      Roles : Security.Policies.Roles.Role_Policy_Access;
   end record;

end AWA.Permissions.Services;

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

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
with Security.Policies.Roles;

with AWA.Applications;
with AWA.Services.Contexts;
package AWA.Permissions.Services is

   package ASC renames AWA.Services.Contexts;

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in ASC.Service_Context_Access)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Initialize the permissions.
   procedure Start (Manager : in out Permission_Manager);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Security.Permissions.Permission_Index);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Get the role names that grant the given permission.
   function Get_Role_Names (Manager : in Permission_Manager;
                            Permission : in Security.Permissions.Permission_Index)
                            return Security.Policies.Roles.Role_Name_Array;

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Security.Permissions.Permission_Index);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Security.Permissions.Permission_Index);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

   --  Delete all the permissions for a user and on the given workspace.
   procedure Delete_Permissions (Session   : in out ADO.Sessions.Master_Session;
                                 User      : in ADO.Identifier;
                                 Workspace : in ADO.Identifier);

private

   type Permission_Array is array (Security.Permissions.Permission_Index) of ADO.Identifier;

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App   : AWA.Applications.Application_Access;
      Roles : Security.Policies.Roles.Role_Policy_Access;

      --  Mapping between the application permission index and the database permission identifier.
      Map   : Permission_Array := (others => 0);
   end record;

end AWA.Permissions.Services;

Refactor the permission manager - Declare the Get_Permission_Manager function - Add a permission index to the Add_Permission procedure - Declare the Permission_Array type


-----------------------------------------------------------------------
--  Util-texts-formats -- Text Format ala Java MessageFormat
--  Copyright (C) 2001, 2002, 2003, 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
generic
   type Stream is limited private;
   type Char is (<>);
   type Input is array (Positive range <>) of Char;
   type Value is limited private;
   type Value_List is array (Positive range <>) of Value;
   with procedure Put (Buffer : in out Stream; C : in Character);
   with function To_Input (Arg : in Value) return Input;
package Util.Texts.Formats is

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   procedure Format (Message   : in Input;
                     Arguments : in Value_List;
                     Into      : in out Stream);

private
   procedure Format (Argument : in Value;
                     Into     : in out Stream);

end Util.Texts.Formats;

-----------------------------------------------------------------------
--  Util-texts-formats -- Text Format ala Java MessageFormat
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
generic
   type Stream is limited private;
   type Char is (<>);
   type Input is array (Positive range <>) of Char;
   type Value is limited private;
   type Value_List is array (Positive range <>) of Value;
   with procedure Put (Buffer : in out Stream; C : in Character);
   with function To_Input (Arg : in Value) return Input;
package Util.Texts.Formats is
   pragma Preelaborate;

   --  Format the message and replace occurrences of argument patterns by
   --  their associated value.
   --  Returns the formatted message in the stream
   procedure Format (Message   : in Input;
                     Arguments : in Value_List;
                     Into      : in out Stream);

private
   procedure Format (Argument : in Value;
                     Into     : in out Stream);

end Util.Texts.Formats;

Add Preelaborate pragma

Add Preelaborate pragma


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

with Util.Streams;
with Util.Streams.Texts;
with EL.Objects;
package ASF.Streams is

   pragma Preelaborate;

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The <b>Print_Stream</b> is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is limited new Util.Streams.Output_Stream with private;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Util.Streams.Texts.Print_Stream_Access);

   --  Initialize the stream
   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Print_Stream'Class);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write a string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Char   : in Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in String);

   --  Write the object converted into a string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in EL.Objects.Object);

   --  Write the buffer array to the output stream.
   procedure Write (Stream : in out Print_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   procedure Flush (Stream : in out Print_Stream);

private

   type Print_Stream is new Ada.Finalization.Limited_Controlled
     and Util.Streams.Output_Stream with record
      Target : Util.Streams.Texts.Print_Stream_Access;
   end record;

end ASF.Streams;

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

with Util.Streams;
with Util.Streams.Texts;
with EL.Objects;
package ASF.Streams is

   pragma Preelaborate;

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The <b>Print_Stream</b> is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is new Ada.Finalization.Limited_Controlled
     and Util.Streams.Output_Stream with private;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Util.Streams.Texts.Print_Stream_Access);

   --  Initialize the stream
   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Print_Stream'Class);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write a string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Char   : in Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in String);

   --  Write the object converted into a string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in EL.Objects.Object);

   --  Write the buffer array to the output stream.
   procedure Write (Stream : in out Print_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   procedure Flush (Stream : in out Print_Stream);

private

   type Print_Stream is new Ada.Finalization.Limited_Controlled
     and Util.Streams.Output_Stream with record
      Target : Util.Streams.Texts.Print_Stream_Access;
   end record;

end ASF.Streams;

Fix compilation with gcc 4.3

Fix compilation with gcc 4.3


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "63";
   copyright_years     : constant String := "2015-2021";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.35.1";
   previous_binutils : constant String := "2.34";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "64";
   copyright_years     : constant String := "2015-2021";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   spkg_nls          : constant String := "nls";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-8.0";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.30";
   default_pgsql     : constant String := "12";
   default_php       : constant String := "7.4";
   default_python3   : constant String := "3.8";
   default_ruby      : constant String := "2.7";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_binutils  : constant String := "binutils:ravensys";
   default_compiler  : constant String := "gcc9";
   previous_default  : constant String := "gcc9";
   compiler_version  : constant String := "9.3.0";
   previous_compiler : constant String := "9.2.0";
   binutils_version  : constant String := "2.35.1";
   previous_binutils : constant String := "2.34";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;
   task_stack_limit  : constant := 10_000_000;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 64;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   raven_var      : constant String := "/var/ravenports";
   host_pkg8      : constant String := host_localbase & "/sbin/ravensw";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Bump version for release

Bump version for release


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

with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Parsers;

package body Natools.S_Expressions.Lockable.Tests is

   -------------------------------
   -- Lockable.Descriptor Tests --
   -------------------------------

   function Test_Expression return Atom is
   begin
      return To_Atom ("(begin(command1 arg1.1 arg1.2)"
        & "(command2 (subcmd2.1 arg2.1.1) (subcmd2.3) arg2.4)"
        & "end)");
   end Test_Expression;

   procedure Test_Interface
     (Test : in out NT.Test;
      Object : in out Lockable.Descriptor'Class)
   is
      Level_1, Level_2 : Lock_State;
      Base : Natural;
   begin
      Base := Object.Current_Level;
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("begin"), Base);

      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, Base + 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("command1"), Base + 1,
        "Before first lock:");
      Object.Lock (Level_1);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("command1"), 0,
        "After first lock:");
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg1.1"), 0);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg1.2"), 0);
      Test_Tools.Next_And_Check (Test, Object, Events.End_Of_Input, 0,
        "Before first unlock:");
      Test_Tools.Test_Atom_Accessor_Exceptions (Test, Object);
      Object.Unlock (Level_1);

      declare
         Event : constant Events.Event := Object.Current_Event;
         Level : constant Natural := Object.Current_Level;
      begin
         if Event /= Events.Close_List then
            Test.Fail ("Current event is " & Events.Event'Image (Event)
              & ", expected Close_List");
         end if;
         if Level /= Base then
            Test.Fail ("Current level is" & Natural'Image (Level)
              & ", expected" & Natural'Image (Base));
         end if;
      end;

      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, Base + 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("command2"), Base + 1,
        "Before second lock:");
      Object.Lock (Level_1);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("command2"), 0,
        "After second lock:");
      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("subcmd2.1"), 1,
        "Before inner lock:");
      Object.Lock (Level_2);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("subcmd2.1"), 0,
        "After inner lock:");
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg2.1.1"), 0,
        "Before inner unlock:");
      Object.Unlock (Level_2, False);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("arg2.1.1"), 1,
        "After inner unlock:");
      Test_Tools.Next_And_Check (Test, Object, Events.Close_List, 0);
      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("subcmd2.3"), 1,
        "Before inner lock:");
      Object.Lock (Level_2);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("subcmd2.3"), 0,
        "After inner lock:");
      Test_Tools.Next_And_Check (Test, Object, Events.End_Of_Input, 0,
        "Before inner unlock:");
      Object.Unlock (Level_2, False);

      declare
         Event : constant Events.Event := Object.Current_Event;
         Level : constant Natural := Object.Current_Level;
      begin
         if Event /= Events.Close_List then
            Test.Fail ("Current event is " & Events.Event'Image (Event)
              & ", expected Close_List");
         end if;
         if Level /= 1 then
            Test.Fail ("Current level is" & Natural'Image (Level)
              & ", expected 1");
         end if;
      end;

      Object.Unlock (Level_1);

      Test_Tools.Next_And_Check (Test, Object, To_Atom ("end"), Base);
      Test_Tools.Next_And_Check (Test, Object, Events.Close_List, Base - 1);
   end Test_Interface;

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

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Test_Stack (Report);
      Test_Wrapper_Interface (Report);
      Test_Wrapper_Extra (Report);
   end All_Tests;

   ---------------------------
   -- Individual Test Cases --
   ---------------------------

   procedure Test_Stack (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Level stack");
   begin
      declare
         Stack : Lock_Stack;
         State : array (1 .. 4) of Lock_State;

         procedure Check_Level
           (Stack : in Lock_Stack;
            Expected : in Natural;
            Context : in String);
         procedure Dump_Data;

         procedure Check_Level
           (Stack : in Lock_Stack;
            Expected : in Natural;
            Context : in String)
         is
            Level : constant Natural := Current_Level (Stack);
         begin
            if Level /= Expected then
               Test.Fail (Context & ": level is"
                 & Natural'Image (Level) & ", expected"
                 & Natural'Image (Expected));
               Dump_Data;
            end if;
         end Check_Level;

         procedure Dump_Data is
         begin
            Test.Info ("   Stack: (Depth =>"
              & Natural'Image (Stack.Depth)
              & ", Level =>"
              & Natural'Image (Stack.Level) & ')');
            for I in State'Range loop
               Test.Info ("   State"
                 & Natural'Image (I)
                 & ": (Depth =>"
                 & Natural'Image (Stack.Depth)
                 & ", Level =>"
                 & Natural'Image (Stack.Level) & ')');
            end loop;
         end Dump_Data;
      begin
         Check_Level (Stack, 0, "1");
         Push_Level (Stack, 14, State (1));
         Check_Level (Stack, 14, "2");

         begin
            Pop_Level (Stack, State (2));
            Test.Fail ("No exception raised after popping blank state");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping blank state");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Pop_Level (Stack, State (1));
         Check_Level (Stack, 0, "3");
         Push_Level (Stack, 15, State (1));
         Check_Level (Stack, 15, "4");
         Push_Level (Stack, 92, State (2));
         Check_Level (Stack, 92, "5");
         Push_Level (Stack, 65, State (3));
         Check_Level (Stack, 65, "6");
         Pop_Level (Stack, State (3));
         Check_Level (Stack, 92, "7");
         Push_Level (Stack, 35, State (3));
         Check_Level (Stack, 35, "8");
         Push_Level (Stack, 89, State (4));
         Check_Level (Stack, 89, "9");

         begin
            Pop_Level (Stack, State (3));
            Test.Fail ("No exception raised after popping a forbidden gap");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping a forbidden gap");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Check_Level (Stack, 89, "10");
         Pop_Level (Stack, State (3), True);
         Check_Level (Stack, 92, "11");

         begin
            Pop_Level (Stack, State (4));
            Test.Fail ("No exception raised after popping stale state");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping stale state");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Check_Level (Stack, 92, "12");
         Pop_Level (Stack, State (2));
         Check_Level (Stack, 15, "13");
         Pop_Level (Stack, State (1));
         Check_Level (Stack, 0, "14");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Stack;

   procedure Test_Wrapper_Extra (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Extra tests of wrapper");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Subparser : aliased Parsers.Subparser (Parser'Access, Input'Access);
         Tested : Wrapper (Subparser'Access);
         State : Lock_State;
      begin
         Input.Set_Data (To_Atom ("(cmd1 arg1)(cmd2 4:arg2"));

         --  Check Events.Error is returned by Next when finished

         Test_Tools.Next_And_Check (Test, Tested, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("cmd1"), 1);
         Tested.Lock (State);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("arg1"), 0);
         Test_Tools.Next_And_Check (Test, Tested, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Tested, Events.Error, 0);
         Tested.Unlock (State);

         --  Run Unlock with End_Of_Input in backend

         Test_Tools.Next_And_Check (Test, Tested, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("cmd2"), 1);
         Tested.Lock (State);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("arg2"), 0);
         Tested.Unlock (State);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Wrapper_Extra;

   procedure Test_Wrapper_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test
        := Report.Item ("Lockable.Descriptor interface of wrapper");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Subparser : aliased Parsers.Subparser (Parser'Access, Input'Access);
         Tested : Wrapper (Subparser'Access);
      begin
         Input.Set_Data (Test_Expression);
         Test_Tools.Next_And_Check (Test, Subparser, Events.Open_List, 1);
         Test_Interface (Test, Tested);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Wrapper_Interface;

end Natools.S_Expressions.Lockable.Tests;

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

with Natools.S_Expressions.Test_Tools;
with Natools.S_Expressions.Parsers;

package body Natools.S_Expressions.Lockable.Tests is

   -------------------------------
   -- Lockable.Descriptor Tests --
   -------------------------------

   function Test_Expression return Atom is
   begin
      return To_Atom ("(begin(command1 arg1.1 arg1.2)"
        & "(command2 (subcmd2.1 arg2.1.1) (subcmd2.3) arg2.4)"
        & "end)");
   end Test_Expression;

   procedure Test_Interface
     (Test : in out NT.Test;
      Object : in out Lockable.Descriptor'Class)
   is
      Level_1, Level_2 : Lock_State;
      Base : Natural;
   begin
      Base := Object.Current_Level;
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("begin"), Base);

      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, Base + 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("command1"), Base + 1,
        "Before first lock:");
      Object.Lock (Level_1);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("command1"), 0,
        "After first lock:");
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg1.1"), 0);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg1.2"), 0);
      Test_Tools.Next_And_Check (Test, Object, Events.End_Of_Input, 0,
        "Before first unlock:");
      Test_Tools.Test_Atom_Accessor_Exceptions (Test, Object);
      Object.Unlock (Level_1);

      declare
         Event : constant Events.Event := Object.Current_Event;
         Level : constant Natural := Object.Current_Level;
      begin
         if Event /= Events.Close_List then
            Test.Fail ("Current event is " & Events.Event'Image (Event)
              & ", expected Close_List");
         end if;
         if Level /= Base then
            Test.Fail ("Current level is" & Natural'Image (Level)
              & ", expected" & Natural'Image (Base));
         end if;
      end;

      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, Base + 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("command2"), Base + 1,
        "Before second lock:");
      Object.Lock (Level_1);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("command2"), 0,
        "After second lock:");
      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("subcmd2.1"), 1,
        "Before inner lock:");
      Object.Lock (Level_2);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("subcmd2.1"), 0,
        "After inner lock:");
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("arg2.1.1"), 0,
        "Before inner unlock:");
      Object.Unlock (Level_2, False);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("arg2.1.1"), 1,
        "After inner unlock:");
      Test_Tools.Next_And_Check (Test, Object, Events.Close_List, 0);
      Test_Tools.Next_And_Check (Test, Object, Events.Open_List, 1);
      Test_Tools.Next_And_Check (Test, Object, To_Atom ("subcmd2.3"), 1,
        "Before inner lock:");
      Object.Lock (Level_2);
      Test_Tools.Test_Atom_Accessors (Test, Object, To_Atom ("subcmd2.3"), 0,
        "After inner lock:");
      Test_Tools.Next_And_Check (Test, Object, Events.End_Of_Input, 0,
        "Before inner unlock:");
      Object.Unlock (Level_2, False);

      declare
         Event : constant Events.Event := Object.Current_Event;
         Level : constant Natural := Object.Current_Level;
      begin
         if Event /= Events.Close_List then
            Test.Fail ("Current event is " & Events.Event'Image (Event)
              & ", expected Close_List");
         end if;
         if Level /= 0 then
            Test.Fail ("Current level is" & Natural'Image (Level)
              & ", expected 0");
         end if;
      end;

      Object.Unlock (Level_1);

      Test_Tools.Next_And_Check (Test, Object, To_Atom ("end"), Base);
      Test_Tools.Next_And_Check (Test, Object, Events.Close_List, Base - 1);
   end Test_Interface;

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

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Test_Stack (Report);
      Test_Wrapper_Interface (Report);
      Test_Wrapper_Extra (Report);
   end All_Tests;

   ---------------------------
   -- Individual Test Cases --
   ---------------------------

   procedure Test_Stack (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Level stack");
   begin
      declare
         Stack : Lock_Stack;
         State : array (1 .. 4) of Lock_State;

         procedure Check_Level
           (Stack : in Lock_Stack;
            Expected : in Natural;
            Context : in String);
         procedure Dump_Data;

         procedure Check_Level
           (Stack : in Lock_Stack;
            Expected : in Natural;
            Context : in String)
         is
            Level : constant Natural := Current_Level (Stack);
         begin
            if Level /= Expected then
               Test.Fail (Context & ": level is"
                 & Natural'Image (Level) & ", expected"
                 & Natural'Image (Expected));
               Dump_Data;
            end if;
         end Check_Level;

         procedure Dump_Data is
         begin
            Test.Info ("   Stack: (Depth =>"
              & Natural'Image (Stack.Depth)
              & ", Level =>"
              & Natural'Image (Stack.Level) & ')');
            for I in State'Range loop
               Test.Info ("   State"
                 & Natural'Image (I)
                 & ": (Depth =>"
                 & Natural'Image (Stack.Depth)
                 & ", Level =>"
                 & Natural'Image (Stack.Level) & ')');
            end loop;
         end Dump_Data;
      begin
         Check_Level (Stack, 0, "1");
         Push_Level (Stack, 14, State (1));
         Check_Level (Stack, 14, "2");

         begin
            Pop_Level (Stack, State (2));
            Test.Fail ("No exception raised after popping blank state");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping blank state");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Pop_Level (Stack, State (1));
         Check_Level (Stack, 0, "3");
         Push_Level (Stack, 15, State (1));
         Check_Level (Stack, 15, "4");
         Push_Level (Stack, 92, State (2));
         Check_Level (Stack, 92, "5");
         Push_Level (Stack, 65, State (3));
         Check_Level (Stack, 65, "6");
         Pop_Level (Stack, State (3));
         Check_Level (Stack, 92, "7");
         Push_Level (Stack, 35, State (3));
         Check_Level (Stack, 35, "8");
         Push_Level (Stack, 89, State (4));
         Check_Level (Stack, 89, "9");

         begin
            Pop_Level (Stack, State (3));
            Test.Fail ("No exception raised after popping a forbidden gap");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping a forbidden gap");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Check_Level (Stack, 89, "10");
         Pop_Level (Stack, State (3), True);
         Check_Level (Stack, 92, "11");

         begin
            Pop_Level (Stack, State (4));
            Test.Fail ("No exception raised after popping stale state");
         exception
            when Constraint_Error =>
               null;
            when Error : others =>
               Test.Fail
                 ("Unexpected exception raised after popping stale state");
               Test.Report_Exception (Error, NT.Fail);
         end;

         Check_Level (Stack, 92, "12");
         Pop_Level (Stack, State (2));
         Check_Level (Stack, 15, "13");
         Pop_Level (Stack, State (1));
         Check_Level (Stack, 0, "14");
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Stack;

   procedure Test_Wrapper_Extra (Report : in out NT.Reporter'Class) is
      Test : NT.Test := Report.Item ("Extra tests of wrapper");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Subparser : aliased Parsers.Subparser (Parser'Access, Input'Access);
         Tested : Wrapper (Subparser'Access);
         State : Lock_State;
      begin
         Input.Set_Data (To_Atom ("(cmd1 arg1)(cmd2 4:arg2"));

         --  Check Events.Error is returned by Next when finished

         Test_Tools.Next_And_Check (Test, Tested, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("cmd1"), 1);
         Tested.Lock (State);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("arg1"), 0);
         Test_Tools.Next_And_Check (Test, Tested, Events.End_Of_Input, 0);
         Test_Tools.Next_And_Check (Test, Tested, Events.Error, 0);
         Tested.Unlock (State);

         --  Run Unlock with End_Of_Input in backend

         Test_Tools.Next_And_Check (Test, Tested, Events.Open_List, 1);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("cmd2"), 1);
         Tested.Lock (State);
         Test_Tools.Next_And_Check (Test, Tested, To_Atom ("arg2"), 0);
         Tested.Unlock (State);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Wrapper_Extra;

   procedure Test_Wrapper_Interface (Report : in out NT.Reporter'Class) is
      Test : NT.Test
        := Report.Item ("Lockable.Descriptor interface of wrapper");
   begin
      declare
         Input : aliased Test_Tools.Memory_Stream;
         Parser : aliased Parsers.Parser;
         Subparser : aliased Parsers.Subparser (Parser'Access, Input'Access);
         Tested : Wrapper (Subparser'Access);
      begin
         Input.Set_Data (Test_Expression);
         Test_Tools.Next_And_Check (Test, Subparser, Events.Open_List, 1);
         Test_Interface (Test, Tested);
      end;
   exception
      when Error : others => Test.Report_Exception (Error);
   end Test_Wrapper_Interface;

end Natools.S_Expressions.Lockable.Tests;

s_expressions-lockable-tests: fix bad expected value in interface test