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

with Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   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) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   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 := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   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 is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   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 := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  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) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

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

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

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

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input);

      procedure Fill (From : in out Stream_Input) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  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) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  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) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

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

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

end Util.Serialize.IO.XML;

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

with Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   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) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   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 := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   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 is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   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 := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  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) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

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

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

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

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input'Class);

      procedure Fill (From : in out Stream_Input'Class) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  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) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  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) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

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

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

end Util.Serialize.IO.XML;

Fix compilation warning

Fix compilation warning


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

with ADO.Sessions;
with ADO.Sessions.Entities;
with ADO.Statements;
with ADO.Queries;
with ADO.SQL;

with Security.Permissions;

with AWA.Permissions;
with AWA.Services.Contexts;
with AWA.Modules.Get;
with AWA.Modules.Beans;
with AWA.Users.Models;
with AWA.Tags.Models;
with AWA.Tags.Beans;
with AWA.Tags.Components;

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

   package ASC renames AWA.Services.Contexts;

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

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

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

      App.Add_Components (AWA.Tags.Components.Definition);

      --  Register the tag list bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Tags.Beans.Tag_List_Bean",
                         Handler => AWA.Tags.Beans.Create_Tag_List_Bean'Access);

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

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

   --  ------------------------------
   --  Get the tags module.
   --  ------------------------------
   function Get_Tag_Module return Tag_Module_Access is
      function Get is new AWA.Modules.Get (Tag_Module, Tag_Module_Access, NAME);
   begin
      return Get;
   end Get_Tag_Module;

   --  ------------------------------
   --  Add a tag on the database entity referenced by <tt>Id</tt> in the table identified
   --  by <tt>Entity_Type</tt>.  The permission represented by <tt>Permission</tt> is checked
   --  to make sure the current user can add the tag.  If the permission is granted, the
   --  tag represented by <tt>Tag</tt> is associated with the said database entity.
   --  ------------------------------
   procedure Add_Tag (Model       : in Tag_Module;
                      Id          : in ADO.Identifier;
                      Entity_Type : in String;
                      Permission  : in String;
                      Tag         : in String) is
      pragma Unreferenced (Model);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      User   : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Ident  : constant String := Entity_Type & ADO.Identifier'Image (Id);
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.Queries.Context;
   begin
      --  Check that the user has the permission on the given object.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Id);

      Log.Info ("User {0} add tag {1} on {2}",
                ADO.Identifier'Image (User.Get_Id), Tag, Ident);

      Query.Set_Query (AWA.Tags.Models.Query_Check_Tag);
      Ctx.Start;
      declare
         Kind     : ADO.Entity_Type := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);
         Stmt     : ADO.Statements.Query_Statement := DB.Create_Statement (Query);
         Tag_Info : AWA.Tags.Models.Tag_Ref;
         Tag_Link : AWA.Tags.Models.Tagged_Entity_Ref;
      begin
         --  Build the query.
         Stmt.Bind_Param (Name => "entity_type", Value => Kind);
         Stmt.Bind_Param (Name => "entity_id", Value => Id);
         Stmt.Bind_Param (Name => "tag", Value => Tag);

         --  Run the query.
         Stmt.Execute;

         if not Stmt.Has_Elements then
            --  The tag is not defined in the database.
            --  Create it and link it to the entity.
            Tag_Info.Set_Name (Tag);
            Tag_Link.Set_Tag (Tag_Info);
            Tag_Link.Set_For_Entity_Id (Id);
            Tag_Link.Set_Entity_Type (Kind);

            Tag_Info.Save (DB);
            Tag_Link.Save (DB);

         elsif Stmt.Is_Null (1) then
            --  The tag is defined but the entity is not linked with it.
            Tag_Info.Set_Id (Stmt.Get_Identifier (0));
            Tag_Link.Set_Tag (Tag_Info);
            Tag_Link.Set_For_Entity_Id (Id);
            Tag_Link.Set_Entity_Type (Kind);
            Tag_Link.Save (DB);
         end if;
      end;
      Ctx.Commit;
   end Add_Tag;

   --  ------------------------------
   --  Remove the tag identified by <tt>Tag</tt> and associated with the database entity
   --  referenced by <tt>Id</tt> in the table identified by <tt>Entity_Type</tt>.
   --  The permission represented by <tt>Permission</tt> is checked to make sure the current user
   --  can remove the tag.
   --  ------------------------------
   procedure Remove_Tag (Model       : in Tag_Module;
                         Id          : in ADO.Identifier;
                         Entity_Type : in String;
                         Permission  : in String;
                         Tag         : in String) is
      pragma Unreferenced (Model);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      User   : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Ident  : constant String := Entity_Type & ADO.Identifier'Image (Id);
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.SQL.Query;
   begin
      --  Check that the user has the permission on the given object.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Id);

      Log.Info ("User {0} removes tag {1} on {2}",
                ADO.Identifier'Image (User.Get_Id), Tag, Ident);

      Query.Set_Join ("INNER JOIN awa_tag AS tag ON tag.id = o.tag_id");
      Query.Set_Filter ("tag.name = :tag AND o.for_entity_id = :entity_id "
                        & "AND o.entity_type = :entity_type");

      Ctx.Start;
      declare
         Kind     : ADO.Entity_Type := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);
         Tag_Link : AWA.Tags.Models.Tagged_Entity_Ref;
         Found    : Boolean;
      begin
         --  Build the query.
         Query.Bind_Param (Name => "entity_type", Value => Kind);
         Query.Bind_Param (Name => "entity_id", Value => Id);
         Query.Bind_Param (Name => "tag", Value => Tag);

         Tag_Link.Find (DB, Query, Found);
         if Found then
            Tag_Link.Delete (DB);
         end if;
      end;
      Ctx.Commit;
   end Remove_Tag;

end AWA.Tags.Modules;

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

with ADO.Sessions;
with ADO.Sessions.Entities;
with ADO.Statements;
with ADO.Queries;
with ADO.SQL;

with Security.Permissions;

with AWA.Permissions;
with AWA.Services.Contexts;
with AWA.Modules.Get;
with AWA.Modules.Beans;
with AWA.Users.Models;
with AWA.Tags.Models;
with AWA.Tags.Beans;
with AWA.Tags.Components;

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

   package ASC renames AWA.Services.Contexts;

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

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

   --  Add a tag on the database entity referenced by <tt>Id</tt> in the table identified
   --  by <tt>Entity_Type</tt>.
   procedure Add_Tag (Session     : in out ADO.Sessions.Master_Session;
                      Id          : in ADO.Identifier;
                      Entity_Type : in ADO.Entity_Type;
                      Tag         : in String);

   --  Remove the tag identified by <tt>Tag</tt> and associated with the database entity
   --  referenced by <tt>Id</tt> in the table identified by <tt>Entity_Type</tt>.
   procedure Remove_Tag (Session     : in out ADO.Sessions.Master_Session;
                         Id          : in ADO.Identifier;
                         Entity_Type : in ADO.Entity_Type;
                         Tag         : in String);

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

      App.Add_Components (AWA.Tags.Components.Definition);

      --  Register the tag list bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Tags.Beans.Tag_List_Bean",
                         Handler => AWA.Tags.Beans.Create_Tag_List_Bean'Access);

      --  Register the tag search bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Tags.Beans.Tag_Search_Bean",
                         Handler => AWA.Tags.Beans.Create_Tag_Search_Bean'Access);

      --  Register the tag info list bean.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Tags.Beans.Tag_Info_List_Bean",
                         Handler => AWA.Tags.Beans.Create_Tag_Info_List_Bean'Access);

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

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

   --  ------------------------------
   --  Get the tags module.
   --  ------------------------------
   function Get_Tag_Module return Tag_Module_Access is
      function Get is new AWA.Modules.Get (Tag_Module, Tag_Module_Access, NAME);
   begin
      return Get;
   end Get_Tag_Module;

   --  ------------------------------
   --  Add a tag on the database entity referenced by <tt>Id</tt> in the table identified
   --  by <tt>Entity_Type</tt>.  The permission represented by <tt>Permission</tt> is checked
   --  to make sure the current user can add the tag.  If the permission is granted, the
   --  tag represented by <tt>Tag</tt> is associated with the said database entity.
   --  ------------------------------
   procedure Add_Tag (Model       : in Tag_Module;
                      Id          : in ADO.Identifier;
                      Entity_Type : in String;
                      Permission  : in String;
                      Tag         : in String) is
      pragma Unreferenced (Model);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      User   : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Ident  : constant String := Entity_Type & ADO.Identifier'Image (Id);
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Kind   : ADO.Entity_Type;
   begin
      --  Check that the user has the permission on the given object.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Id);

      Log.Info ("User {0} add tag {1} on {2}",
                ADO.Identifier'Image (User.Get_Id), Tag, Ident);

      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);
      Add_Tag (DB, Id, Kind, Tag);
      Ctx.Commit;
   end Add_Tag;

   --  ------------------------------
   --  Remove the tag identified by <tt>Tag</tt> and associated with the database entity
   --  referenced by <tt>Id</tt> in the table identified by <tt>Entity_Type</tt>.
   --  The permission represented by <tt>Permission</tt> is checked to make sure the current user
   --  can remove the tag.
   --  ------------------------------
   procedure Remove_Tag (Model       : in Tag_Module;
                         Id          : in ADO.Identifier;
                         Entity_Type : in String;
                         Permission  : in String;
                         Tag         : in String) is
      pragma Unreferenced (Model);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      User   : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Ident  : constant String := Entity_Type & ADO.Identifier'Image (Id);
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Kind   : ADO.Entity_Type;
   begin
      --  Check that the user has the permission on the given object.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Id);

      Log.Info ("User {0} removes tag {1} on {2}",
                ADO.Identifier'Image (User.Get_Id), Tag, Ident);

      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);
      Remove_Tag (DB, Id, Kind, Tag);
      Ctx.Commit;
   end Remove_Tag;

   --  ------------------------------
   --  Remove the tags defined by the <tt>Deleted</tt> tag list and add the tags defined
   --  in the <tt>Added</tt> tag list.  The tags are associated with the database entity
   --  referenced by <tt>Id</tt> in the table identified by <tt>Entity_Type</tt>.
   --  The permission represented by <tt>Permission</tt> is checked to make sure the current user
   --  can remove or add the tag.
   --  ------------------------------
   procedure Update_Tags (Model       : in Tag_Module;
                          Id          : in ADO.Identifier;
                          Entity_Type : in String;
                          Permission  : in String;
                          Added       : in Util.Strings.Vectors.Vector;
                          Deleted     : in Util.Strings.Vectors.Vector) is
      pragma Unreferenced (Model);

      Ctx    : constant ASC.Service_Context_Access := ASC.Current;
      User   : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Ident  : constant String := Entity_Type & ADO.Identifier'Image (Id);
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Kind   : ADO.Entity_Type;
      Iter   : Util.Strings.Vectors.Cursor;
   begin
      --  Check that the user has the permission on the given object.
      AWA.Permissions.Check (Permission => Security.Permissions.Get_Permission_Index (Permission),
                             Entity     => Id);

      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);

      --  Delete the tags that have been removed.
      Iter := Deleted.First;
      while Util.Strings.Vectors.Has_Element (Iter) loop
         declare
            Tag : constant String := Util.Strings.Vectors.Element (Iter);
         begin
            Log.Info ("User {0} removes tag {1} on {2}",
                      ADO.Identifier'Image (User.Get_Id), Tag, Ident);

            Remove_Tag (DB, Id, Kind, Tag);
         end;
         Util.Strings.Vectors.Next (Iter);
      end loop;

      --  And add the new ones.
      Iter := Added.First;
      while Util.Strings.Vectors.Has_Element (Iter) loop
         declare
            Tag : constant String := Util.Strings.Vectors.Element (Iter);
         begin
            Log.Info ("User {0} adds tag {1} on {2}",
                      ADO.Identifier'Image (User.Get_Id), Tag, Ident);

            Add_Tag (DB, Id, Kind, Tag);
         end;
         Util.Strings.Vectors.Next (Iter);
      end loop;
      Ctx.Commit;
   end Update_Tags;

   --  ------------------------------
   --  Add a tag on the database entity referenced by <tt>Id</tt> in the table identified
   --  by <tt>Entity_Type</tt>.
   --  ------------------------------
   procedure Add_Tag (Session     : in out ADO.Sessions.Master_Session;
                      Id          : in ADO.Identifier;
                      Entity_Type : in ADO.Entity_Type;
                      Tag         : in String) is
      Query    : ADO.Queries.Context;
      Tag_Info : AWA.Tags.Models.Tag_Ref;
      Tag_Link : AWA.Tags.Models.Tagged_Entity_Ref;
   begin
      Query.Set_Query (AWA.Tags.Models.Query_Check_Tag);

      declare
         Stmt : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      begin
         --  Build the query.
         Stmt.Bind_Param (Name => "entity_type", Value => Entity_Type);
         Stmt.Bind_Param (Name => "entity_id", Value => Id);
         Stmt.Bind_Param (Name => "tag", Value => Tag);

         --  Run the query.
         Stmt.Execute;

         if not Stmt.Has_Elements then
            --  The tag is not defined in the database.
            --  Create it and link it to the entity.
            Tag_Info.Set_Name (Tag);
            Tag_Link.Set_Tag (Tag_Info);
            Tag_Link.Set_For_Entity_Id (Id);
            Tag_Link.Set_Entity_Type (Entity_Type);

            Tag_Info.Save (Session);
            Tag_Link.Save (Session);

         elsif Stmt.Is_Null (1) then
            --  The tag is defined but the entity is not linked with it.
            Tag_Info.Set_Id (Stmt.Get_Identifier (0));
            Tag_Link.Set_Tag (Tag_Info);
            Tag_Link.Set_For_Entity_Id (Id);
            Tag_Link.Set_Entity_Type (Entity_Type);
            Tag_Link.Save (Session);
         end if;
      end;
   end Add_Tag;

   --  ------------------------------
   --  Remove the tag identified by <tt>Tag</tt> and associated with the database entity
   --  referenced by <tt>Id</tt> in the table identified by <tt>Entity_Type</tt>.
   --  ------------------------------
   procedure Remove_Tag (Session     : in out ADO.Sessions.Master_Session;
                         Id          : in ADO.Identifier;
                         Entity_Type : in ADO.Entity_Type;
                         Tag         : in String) is
      Query    : ADO.SQL.Query;
      Tag_Link : AWA.Tags.Models.Tagged_Entity_Ref;
      Found    : Boolean;
   begin
      Query.Set_Join ("INNER JOIN awa_tag AS tag ON tag.id = o.tag_id");
      Query.Set_Filter ("tag.name = :tag AND o.for_entity_id = :entity_id "
                        & "AND o.entity_type = :entity_type");

      --  Build the query.
      Query.Bind_Param (Name => "entity_type", Value => Entity_Type);
      Query.Bind_Param (Name => "entity_id", Value => Id);
      Query.Bind_Param (Name => "tag", Value => Tag);

      Tag_Link.Find (Session, Query, Found);
      if Found then
         Tag_Link.Delete (Session);
      end if;
   end Remove_Tag;

   --  ------------------------------
   --  Find the tag identifier associated with the given tag.
   --  Return NO_IDENTIFIER if there is no such tag.
   --  ------------------------------
   procedure Find_Tag_Id (Session : in out ADO.Sessions.Session'Class;
                          Tag     : in String;
                          Result  : out ADO.Identifier) is
   begin
      if Tag'Length = 0 then
         Result := ADO.NO_IDENTIFIER;
      else
         declare
            Query    : ADO.SQL.Query;
            Found    : Boolean;
            Tag_Info : AWA.Tags.Models.Tag_Ref;
         begin
            Query.Set_Filter ("o.name = ?");
            Query.Bind_Param (1, Tag);
            Tag_Info.Find (Session => Session,
                           Query   => Query,
                           Found   => Found);
            if not Found then
               Result := ADO.NO_IDENTIFIER;
            else
               Result := Tag_Info.Get_Id;
            end if;
         end;
      end if;
   end Find_Tag_Id;

end AWA.Tags.Modules;

Implement new procedure Update_Tags and Find_Tag_Id Refactor the creation and removal of tags Register the new beans


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

with Security.Permissions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
private with Ada.Strings.Unbounded;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   subtype Permission_Index_Array is Security.Permissions.Permission_Index_Array;

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   --  The configuration parameter that defines the list of permissions to grant
   --  to a user when his workspace is created.
   PARAM_PERMISSIONS_LIST : constant String := "permissions_list";

   --  Permission to create a workspace.
   package ACL_Create_Workspace is new Security.Permissions.Definition ("workspace-create");
   package ACL_Invite_User is new Security.Permissions.Definition ("workspace-invite-user");
   package ACL_Delete_User is new Security.Permissions.Definition ("workspace-delete-user");

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Workspace_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the list of permissions for the workspace owner.
   function Get_Owner_Permissions (Manager : in Workspace_Module) return Permission_Index_Array;

   --  Get the workspace module.
   function Get_Workspace_Module return Workspace_Module_Access;

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Create a workspace for the user.
   procedure Create_Workspace (Module    : in Workspace_Module;
                               Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

   --  Add a list of permissions for all the users of the workspace that have the appropriate
   --  role.  Workspace members will be able to access the given database entity for the
   --  specified list of permissions.
   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;
                             List       : in Security.Permissions.Permission_Index_Array);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;

      --  The list of permissions to grant to a user who creates the workspace.
      Owner_Permissions : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Workspaces.Modules;

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

with Security.Permissions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Permissions.Services;
with AWA.Events;
private with Ada.Strings.Unbounded;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   subtype Permission_Index_Array is Security.Permissions.Permission_Index_Array;

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   --  The configuration parameter that defines the list of permissions to grant
   --  to a user when his workspace is created.
   PARAM_PERMISSIONS_LIST : constant String := "permissions_list";

   --  A boolean configuration parameter that indicates that new users can create
   --  a workspace.  When a user is created, the 'workspace-create' permission is
   --  added so that they can create the workspace.
   PARAM_ALLOW_WORKSPACE_CREATE : constant String := "allow_workspace_create";

   --  Permission to create a workspace.
   package ACL_Create_Workspace is new Security.Permissions.Definition ("workspace-create");
   package ACL_Invite_User is new Security.Permissions.Definition ("workspace-invite-user");
   package ACL_Delete_User is new Security.Permissions.Definition ("workspace-delete-user");

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module and AWA.Users.Services.Listener with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Workspace_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the list of permissions for the workspace owner.
   function Get_Owner_Permissions (Manager : in Workspace_Module) return Permission_Index_Array;

   --  Get the workspace module.
   function Get_Workspace_Module return Workspace_Module_Access;

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Create a workspace for the user.
   procedure Create_Workspace (Module    : in Workspace_Module;
                               Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

   --  Add a list of permissions for all the users of the workspace that have the appropriate
   --  role.  Workspace members will be able to access the given database entity for the
   --  specified list of permissions.
   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;
                             List       : in Security.Permissions.Permission_Index_Array);

   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the user.
   overriding
   procedure On_Create (Module : in Workspace_Module;
                        User   : in AWA.Users.Models.User_Ref'Class);

   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the user.
   overriding
   procedure On_Update (Module : in Workspace_Module;
                        User   : in AWA.Users.Models.User_Ref'Class) is null;

   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the user.
   overriding
   procedure On_Delete (Module : in Workspace_Module;
                        User   : in AWA.Users.Models.User_Ref'Class) is null;

private

   type Workspace_Module is new AWA.Modules.Module and AWA.Users.Services.Listener with record
      User_Manager      : AWA.Users.Services.User_Service_Access;

      --  The permission manager.
      Perm_Manager      : AWA.Permissions.Services.Permission_Manager_Access;

      --  The list of permissions to grant to a user who creates the workspace.
      Owner_Permissions : Ada.Strings.Unbounded.Unbounded_String;

      --  When set, allow new users to create a workspace.
      Allow_WS_Create   : Boolean := False;
   end record;

end AWA.Workspaces.Modules;

Implement the AWA.Users.Services.Listener interface to be notified when a user is created Declare the PARAM_ALLOW_WORKSPACE_CREATE constant


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

   use Ada.Characters.Conversions;

   Value_Range : constant Long_Long_Integer := T'Pos (T'Last) - T'Pos (T'First) + 1;

   --  ------------------------------
   --  Integer Type
   --  ------------------------------
   type Enum_Type is new Int_Type with null record;

   --  Get the type name
   overriding
   function Get_Name (Type_Def : in Enum_Type) return String;

   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String;

   --  ------------------------------
   --  Get the type name
   --  ------------------------------
   overriding
   function Get_Name (Type_Def : Enum_Type) return String is
      pragma Unreferenced (Type_Def);
   begin
      return "Enum";
   end Get_Name;

   --  ------------------------------
   --  Convert the value into a string.
   --  ------------------------------
   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String is
      pragma Unreferenced (Type_Def);
   begin
      return T'Image (T'Val (Value.Int_Value));
   end To_String;

   Value_Type  : aliased constant Enum_Type := Enum_Type '(null record);

   --  ------------------------------
   --  Create an object from the given value.
   --  ------------------------------
   function To_Object (Value : in T) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type   => TYPE_INTEGER,
                            Int_Value => Long_Long_Integer (T'Pos (Value))),
        Type_Def  => Value_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Convert the object into a value.
   --  Raises Constraint_Error if the object cannot be converter to the target type.
   --  ------------------------------
   function To_Value (Value : in Util.Beans.Objects.Object) return T is
   begin
      case Value.V.Of_Type is
         when TYPE_INTEGER =>
            if ROUND_VALUE then
               return T'Val (Value.V.Int_Value mod Value_Range);
            else
               return T'Val (Value.V.Int_Value);
            end if;

         when TYPE_BOOLEAN =>
            return T'Val (Boolean'Pos (Value.V.Bool_Value));

         when TYPE_FLOAT =>
            if ROUND_VALUE then
               return T'Val (To_Long_Long_Integer (Value) mod Value_Range);
            else
               return T'Val (To_Long_Long_Integer (Value));
            end if;

         when TYPE_STRING =>
            if Value.V.String_Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (Value.V.String_Proxy.Value);

         when TYPE_WIDE_STRING =>
            if Value.V.Wide_Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (To_String (Value.V.Wide_Proxy.Value));

         when TYPE_NULL =>
            raise Constraint_Error with "The object value is null";

         when TYPE_TIME =>
            raise Constraint_Error with "Cannot convert a date into a discrete type";

         when TYPE_BEAN =>
            raise Constraint_Error with "Cannot convert a bean into a discrete type";

      end case;
   end To_Value;

end Util.Beans.Objects.Enums;

-----------------------------------------------------------------------
--  Util.Beans.Objects.Enums -- Helper conversion for discrete types
--  Copyright (C) 2010, 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 Ada.Characters.Conversions;
package body Util.Beans.Objects.Enums is

   use Ada.Characters.Conversions;

   Value_Range : constant Long_Long_Integer := T'Pos (T'Last) - T'Pos (T'First) + 1;

   --  ------------------------------
   --  Integer Type
   --  ------------------------------
   type Enum_Type is new Int_Type with null record;

   --  Get the type name
   overriding
   function Get_Name (Type_Def : in Enum_Type) return String;

   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String;

   --  ------------------------------
   --  Get the type name
   --  ------------------------------
   overriding
   function Get_Name (Type_Def : Enum_Type) return String is
      pragma Unreferenced (Type_Def);
   begin
      return "Enum";
   end Get_Name;

   --  ------------------------------
   --  Convert the value into a string.
   --  ------------------------------
   overriding
   function To_String (Type_Def : in Enum_Type;
                       Value    : in Object_Value) return String is
      pragma Unreferenced (Type_Def);
   begin
      return T'Image (T'Val (Value.Int_Value));
   end To_String;

   Value_Type  : aliased constant Enum_Type := Enum_Type '(null record);

   --  ------------------------------
   --  Create an object from the given value.
   --  ------------------------------
   function To_Object (Value : in T) return Object is
   begin
      return Object '(Controlled with
        V => Object_Value '(Of_Type   => TYPE_INTEGER,
                            Int_Value => Long_Long_Integer (T'Pos (Value))),
        Type_Def  => Value_Type'Access);
   end To_Object;

   --  ------------------------------
   --  Convert the object into a value.
   --  Raises Constraint_Error if the object cannot be converter to the target type.
   --  ------------------------------
   function To_Value (Value : in Util.Beans.Objects.Object) return T is
   begin
      case Value.V.Of_Type is
         when TYPE_INTEGER =>
            if ROUND_VALUE then
               return T'Val (Value.V.Int_Value mod Value_Range);
            else
               return T'Val (Value.V.Int_Value);
            end if;

         when TYPE_BOOLEAN =>
            return T'Val (Boolean'Pos (Value.V.Bool_Value));

         when TYPE_FLOAT =>
            if ROUND_VALUE then
               return T'Val (To_Long_Long_Integer (Value) mod Value_Range);
            else
               return T'Val (To_Long_Long_Integer (Value));
            end if;

         when TYPE_STRING =>
            if Value.V.String_Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (Value.V.String_Proxy.Value);

         when TYPE_WIDE_STRING =>
            if Value.V.Wide_Proxy = null then
               raise Constraint_Error with "The object value is null";
            end if;
            return T'Value (To_String (Value.V.Wide_Proxy.Value));

         when TYPE_NULL =>
            raise Constraint_Error with "The object value is null";

         when TYPE_TIME =>
            raise Constraint_Error with "Cannot convert a date into a discrete type";

         when TYPE_BEAN =>
            raise Constraint_Error with "Cannot convert a bean into a discrete type";

         when TYPE_ARRAY =>
            raise Constraint_Error with "Cannot convert an array into a discrete type";

      end case;
   end To_Value;

end Util.Beans.Objects.Enums;

Raise a Constraint_Error exception if we try to convert an array to the enum value


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

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Stream'Class);

   --  Write the string to the stream.
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String);

   --  ------------------------------
   --  Write an optional newline or space.
   --  ------------------------------
   overriding
   procedure Newline (Writer : in out Html_Output_Stream) is
   begin
      if Writer.Indent_Level > 0 and Writer.Text_Length > 0 then
         Writer.Write (Wiki.Helpers.LF);
         Writer.Empty_Line := True;
      end if;
      Writer.Text_Length := 0;
   end Newline;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
         Stream.Empty_Line := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the string to the stream.
   --  ------------------------------
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Stream.Write (Wiki.Strings.To_WChar (Content (I)));
      end loop;
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      end if;
   end Write_String;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString) is
   begin
      if Stream.Close_Start then
         Html.Write_Escape_Attribute (Stream, Name, Wiki.Strings.To_WString (Content));
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is
   begin
      if Stream.Close_Start then
         Stream.Write_Escape_Attribute (Name, Content);
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Start an XML element with the given name.
   --  ------------------------------
   overriding
   procedure Start_Element (Stream : in out Html_Output_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Indent_Pos := Stream.Indent_Pos + Stream.Indent_Level;
      if Stream.Indent_Pos > 1 then
         if not Stream.Empty_Line then
            Stream.Write (Helpers.LF);
         end if;
         for I in 1 .. Stream.Indent_Pos loop
            Stream.Write (' ');
         end loop;
      end if;
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
      Stream.Text_Length := 0;
      Stream.Empty_Line := False;
   end Start_Element;

   --  ------------------------------
   --  Closes an XML element of the given name.
   --  ------------------------------
   overriding
   procedure End_Element (Stream : in out Html_Output_Stream;
                          Name   : in String) is
   begin
      if Stream.Indent_Pos > Stream.Indent_Level then
         Stream.Indent_Pos := Stream.Indent_Pos - Stream.Indent_Level;
      end if;
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         if Stream.Text_Length = 0 then
            if not Stream.Empty_Line then
               Stream.Write (Wiki.Helpers.LF);
            end if;
            if Stream.Indent_Pos > 1 then
               Stream.Write (Helpers.LF);
               for I in 1 .. Stream.Indent_Pos loop
                  Stream.Write (' ');
               end loop;
            end if;
         end if;
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
      if Stream.Indent_Level > 0 then
         Stream.Write (Wiki.Helpers.LF);
         Stream.Empty_Line := True;
      end if;
      Stream.Text_Length := 0;
   end End_Element;

   --  ------------------------------
   --  Write a text escaping any character as necessary.
   --  ------------------------------
   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      Stream.Write_Escape (Content);
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      end if;
   end Write_Wide_Text;

end Wiki.Streams.Html.Stream;

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

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Html_Output_Stream'Class);

   --  Write the string to the stream.
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String);

   --  ------------------------------
   --  Set the indentation level for HTML output stream.
   --  ------------------------------
   overriding
   procedure Set_Indent_Level (Writer : in out Html_Output_Stream;
                               Indent : in Natural) is
   begin
      Writer.Indent_Level := Indent;
   end Set_Indent_Level;

   --  ------------------------------
   --  Write an optional newline or space.
   --  ------------------------------
   overriding
   procedure Newline (Writer : in out Html_Output_Stream) is
   begin
      if Writer.Indent_Level > 0 and Writer.Text_Length > 0 then
         Writer.Write (Wiki.Helpers.LF);
         Writer.Empty_Line := True;
      end if;
      Writer.Text_Length := 0;
   end Newline;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
         Stream.Empty_Line := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the string to the stream.
   --  ------------------------------
   procedure Write_String (Stream  : in out Html_Output_Stream'Class;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Stream.Write (Wiki.Strings.To_WChar (Content (I)));
      end loop;
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      end if;
   end Write_String;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wiki.Strings.UString) is
   begin
      if Stream.Close_Start then
         Html.Write_Escape_Attribute (Stream, Name, Wiki.Strings.To_WString (Content));
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Write an XML attribute within an XML element.
   --  The attribute value is escaped according to the XML escape rules.
   --  ------------------------------
   overriding
   procedure Write_Wide_Attribute (Stream  : in out Html_Output_Stream;
                                   Name    : in String;
                                   Content : in Wide_Wide_String) is
   begin
      if Stream.Close_Start then
         Stream.Write_Escape_Attribute (Name, Content);
      end if;
   end Write_Wide_Attribute;

   --  ------------------------------
   --  Start an XML element with the given name.
   --  ------------------------------
   overriding
   procedure Start_Element (Stream : in out Html_Output_Stream;
                            Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Indent_Pos := Stream.Indent_Pos + Stream.Indent_Level;
      if Stream.Indent_Pos > 1 then
         if not Stream.Empty_Line then
            Stream.Write (Helpers.LF);
         end if;
         for I in 1 .. Stream.Indent_Pos loop
            Stream.Write (' ');
         end loop;
      end if;
      Stream.Write ('<');
      Stream.Write_String (Name);
      Stream.Close_Start := True;
      Stream.Text_Length := 0;
      Stream.Empty_Line := False;
   end Start_Element;

   --  ------------------------------
   --  Closes an XML element of the given name.
   --  ------------------------------
   overriding
   procedure End_Element (Stream : in out Html_Output_Stream;
                          Name   : in String) is
   begin
      if Stream.Indent_Pos > Stream.Indent_Level then
         Stream.Indent_Pos := Stream.Indent_Pos - Stream.Indent_Level;
      end if;
      if Stream.Close_Start then
         Stream.Write (" />");
         Stream.Close_Start := False;
      else
         Close_Current (Stream);
         if Stream.Text_Length = 0 then
            if not Stream.Empty_Line and Stream.Indent_Level > 0 then
               Stream.Write (Wiki.Helpers.LF);
            end if;
            if Stream.Indent_Pos > 1 then
               Stream.Write (Helpers.LF);
               for I in 1 .. Stream.Indent_Pos loop
                  Stream.Write (' ');
               end loop;
            end if;
         end if;
         Stream.Write ("</");
         Stream.Write_String (Name);
         Stream.Write ('>');
      end if;
      if Stream.Indent_Level > 0 then
         Stream.Write (Wiki.Helpers.LF);
         Stream.Empty_Line := True;
      end if;
      Stream.Text_Length := 0;
   end End_Element;

   --  ------------------------------
   --  Write a text escaping any character as necessary.
   --  ------------------------------
   overriding
   procedure Write_Wide_Text (Stream  : in out Html_Output_Stream;
                              Content : in Wiki.Strings.WString) is
   begin
      Close_Current (Stream);
      Stream.Write_Escape (Content);
      if Content'Length > 0 then
         Stream.Text_Length := Stream.Text_Length + Content'Length;
         Stream.Empty_Line := False;
      else
         Stream.Write (' ');
      end if;
   end Write_Wide_Text;

end Wiki.Streams.Html.Stream;

Add Set_Indent_Level

Add Set_Indent_Level