private with Ada.Finalization;

private with Interfaces;
private with Interfaces.C;
private with Interfaces.C.Pointers;

private with System;

package YAML is

   type UTF8_String is new String;

   type Document_Type is tagged limited private;
   --  Holder for a YAML document

   type Node_Kind is
     (No_Node,
      --  An empty node

      Scalar_Node,
      --  A scalar node

      Sequence_Node,
      --  A sequence node

      Mapping_Node
      --  A mapping node
     ) with
      Convention => C;
   --  Type of a node in a document

   type Node_Ref is private;
   --  Reference to a node as part of a document. Such values must not outlive
   --  the value for the document that owns them.

   No_Node_Ref : constant Node_Ref;

   function Root_Node (Document : Document_Type'Class) return Node_Ref;
   --  Return the root node of a document, or No_Node_Ref for an empty
   --  document.

   function Kind (Node : Node_Ref) return Node_Kind;
   --  Return the type of a node

   function Value (Node : Node_Ref) return UTF8_String
      with Pre => Kind (Node) = Scalar_Node;

   function Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) in Sequence_Node | Mapping_Node;
   --  Return the number of items in the Node sequence/mapping

   function Item (Node : Node_Ref; Index : Positive) return Node_Ref
      with Pre => Kind (Node) = Sequence_Node;
   --  Return the Index'th item in Node. Index is 1-based.

   type Node_Pair is record
      Key, Value : Node_Ref;
   end record;
   --  Key/value asssociation in a mapping node

   function Item (Node : Node_Ref; Index : Positive) return Node_Pair
      with Pre => Kind (Node) = Mapping_Node;
   --  Return the Index'th key/value association in Node. Index is 1-based.

   function Item (Node : Node_Ref; Key : UTF8_String) return Node_Ref
      with Pre => Kind (Node) = Mapping_Node;
   --  Look for Key in the Node mapping. If there is one, return the
   --  corresponding Value. Return No_Node_Ref otherwise.

   type Parser_Type is tagged limited private;
   --  YAML document parser

   type Encoding_Type is
     (Any_Encoding,
      --  Let the parser choose the encoding

      UTF8_Encoding,
      --  The default UTF-8 encoding

      UTF16LE_Encoding,
      --  The UTF-16-LE encoding with BOM

      UTF16BE_Encoding
      --  The UTF-16-BE encoding with BOM
     ) with
      Convention => C;
   --  Stream encoding

   procedure Set_Input_String
     (Parser   : in out Parser_Type'Class;
      Input    : String;
      Encoding : Encoding_Type);
   --  Set a string input. This maintains a copy of Input in Parser.

   File_Error : exception;
   --  Exception raised when file-related errors occurs. For instance: cannot
   --  open a file, cannot read a file, etc.

   procedure Set_Input_File
     (Parser   : in out Parser_Type'Class;
      Filename : String;
      Encoding : Encoding_Type);
   --  Set a file input. This opens Filename until the parser is destroyed or
   --  until another Set_Input_* procedure is successfuly called. If an error
   --  occurs while opening the file, raise a File_Error and leave the parser
   --  unmodified.

   function Load (Parser : in out Parser_Type'Class) return Document_Type;
   --  Parse the input stream and produce the next YAML document.
   --
   --  Call this function subsequently to produce a sequence of documents
   --  constituting the input stream. If the produced document has no root
   --  node, it means that the document end has been reached.
   --
   --  TODO: error handling

private

   subtype C_Int is Interfaces.C.int;
   subtype C_Index is C_Int range 0 .. C_Int'Last;
   subtype C_Ptr_Diff is Interfaces.C.ptrdiff_t;

   type C_Char_Array is array (C_Index) of Interfaces.Unsigned_8;
   type C_Char_Access is access all C_Char_Array;

   type C_Node_T;
   type C_Node_Access is access all C_Node_T;

   type C_Scalar_Style_T is
     (Any_Scalar_Style,
      Plain_Scalar_Style,
      Single_Quoted_Scalar_Style,
      Double_Quoted_Scalar_Style,
      Literal_Scalar_Style,
      Folded_Scalar_Style) with
      Convention => C;
   --  Scalar styles

   type C_Sequence_Style_T is
     (Any_Sequence_Style,
      Block_Sequence_Style,
      Flow_Sequence_Style) with
      Convention => C;
   --  Sequence styles

   type C_Mapping_Style_T is
     (Any_Mapping_Style,
      Block_Mapping_Style,
      Flow_Mapping_Style) with
      Convention => C;
   --  Mapping styles

   type C_Mark_T is record
      Index, Line, Column : Interfaces.C.size_t;
   end record with
      Convention => C_Pass_By_Copy;
   --  The pointer position

   type C_Version_Directive_T is record
      Major, Minor : C_Int;
      --  Major and minor version numbers
   end record with
      Convention => C_Pass_By_Copy;
   --  The version directive data

   type C_Version_Directive_Access is access all C_Version_Directive_T;

   type C_Tag_Directive_T is record
      Handle : C_Char_Access;
      --  The tag handle

      Prefix : C_Char_Access;
      --  The tag prefix
   end record with
      Convention => C_Pass_By_Copy;
   --  The tag directive data

   type C_Tag_Directive_Access is access C_Tag_Directive_T;

   subtype C_Node_Item_T is C_Int;
   type C_Node_Item_Array is array (C_Index range <>) of aliased C_Node_Item_T;
   package C_Node_Item_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Item_T,
      Element_Array      => C_Node_Item_Array,
      Default_Terminator => -1);
   subtype C_Node_Item_Access is C_Node_Item_Accesses.Pointer;

   type C_Node_Pair_T is record
      Key, Value : C_Int;
   end record with
      Convention => C_Pass_By_Copy;
   type C_Node_Pair_Array is array (C_Index range <>) of aliased C_Node_Pair_T;
   package C_Node_Pair_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Pair_T,
      Element_Array      => C_Node_Pair_Array,
      Default_Terminator => (-1, -1));
   subtype C_Node_Pair_Access is C_Node_Pair_Accesses.Pointer;

   ----------------------------
   -- Node structure binding --
   ----------------------------

   type C_Scalar_Node_Data is record
      Value  : C_Char_Access;
      --  The scalar value

      Length : Interfaces.C.size_t;
      --  The length of the scalar value

      Style  : C_Scalar_Style_T;
      --  The scalar style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Items is record
      Seq_Start, Seq_End, Seq_Top : C_Node_Item_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Node_Data is record
      Items : C_Sequence_Items;
      --  The stack of sequence items

      Style : C_Sequence_Style_T;
      --  The sequence style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Pairs is record
      Map_Start, Map_End, Map_Top : C_Node_Pair_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Node_Data is record
      Pairs : C_Mapping_Pairs;
      --  The stack of mapping pairs

      Style : C_Mapping_Style_T;
      --  The mapping style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Node_Data (Dummy : Node_Kind := No_Node) is record
      case Dummy is
         when No_Node =>
            null;

         when Scalar_Node =>
            Scalar : C_Scalar_Node_Data;
            --  The scalar parameters (for Scalar_Node)

         when Sequence_Node =>
            Sequence : C_Sequence_Node_Data;
            --  The sequence parameters (for Sequence_Node)

         when Mapping_Node =>
            Mapping : C_Mapping_Node_Data;
            --  The mapping parameters (for Mapping_Node)
      end case;
   end record with
      Convention => C_Pass_By_Copy,
      Unchecked_Union;

   type C_Node_T is record
      Kind : Node_Kind;
      --  The node type

      Tag  : C_Char_Access;
      --  The node tag

      Data : C_Node_Data;
      --  The node data

      Start_Mark, End_Mark : C_Mark_T;
   end record with
      Convention => C_Pass_By_Copy;

   --------------------------------
   -- Document structure binding --
   --------------------------------

   type C_Document_Nodes is record
      Start_Node, End_Node, Top_Node : C_Node_T;
      --  Begining, end and top of the stack
   end record with
      Convention => C_Pass_By_Copy;

   type C_Tag_Directives is record
      Start_Dir, End_Dir : C_Tag_Directive_Access;
      --  Beginning and end of the tag directives list
   end record with
      Convention => C_Pass_By_Copy;

   type C_Document_T is record
      Nodes                        : C_Document_Nodes;
      --  The document nodes

      Version_Directives           : C_Version_Directive_Access;
      --  The version directive

      Tag_Directives               : C_Tag_Directives;
      --  The list of tag directives

      Start_Implicit, End_Implicit : C_Int;
      --  Is the document start/end indicator explicit?

      Start_Mark, End_Mark         : C_Mark_T;
      --  Beginning and end of the document
   end record with
      Convention => C_Pass_By_Copy;
   --  The document structure

   type C_Document_Access is access all C_Document_T;

   -------------------------
   -- High-level Wrappers --
   -------------------------

   type Document_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Doc     : aliased C_Document_T;
      To_Delete : Boolean;
   end record;

   overriding procedure Initialize (Document : in out Document_Type);
   overriding procedure Finalize (Document : in out Document_Type);

   type Document_Access is access all Document_Type'Class;

   type Node_Ref is record
      Node     : C_Node_Access;
      --  The referenced node

      Document : Document_Access;
      --  The document it belongs to
   end record;

   No_Node_Ref : constant Node_Ref := (null, null);

   type C_Parser_Access is new System.Address;
   type String_Access is access String;

   type C_File_Ptr is new System.Address;
   No_File_Ptr : constant C_File_Ptr := C_File_Ptr (System.Null_Address);

   type Parser_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Parser       : C_Parser_Access;
      Input_Encoding : Encoding_Type;
      Input_String   : String_Access;
      Input_File     : C_File_Ptr;
   end record;

   overriding procedure Initialize (Parser : in out Parser_Type);
   overriding procedure Finalize (Parser : in out Parser_Type);

end YAML;

private with Ada.Finalization;

private with Interfaces;
private with Interfaces.C;
private with Interfaces.C.Pointers;

private with System;

package YAML is

   type UTF8_String is new String;

   type Document_Type is tagged limited private;
   --  Holder for a YAML document

   type Node_Kind is
     (No_Node,
      --  An empty node

      Scalar_Node,
      --  A scalar node

      Sequence_Node,
      --  A sequence node

      Mapping_Node
      --  A mapping node
     ) with
      Convention => C;
   --  Type of a node in a document

   type Node_Ref is private;
   --  Reference to a node as part of a document. Such values must not outlive
   --  the value for the document that owns them.

   No_Node_Ref : constant Node_Ref;

   function Root_Node (Document : Document_Type'Class) return Node_Ref;
   --  Return the root node of a document, or No_Node_Ref for an empty
   --  document.

   function Kind (Node : Node_Ref) return Node_Kind;
   --  Return the type of a node

   function Value (Node : Node_Ref) return UTF8_String
      with Pre => Kind (Node) = Scalar_Node;

   function Length (Node : Node_Ref) return Natural
      with Pre => Kind (Node) in Sequence_Node | Mapping_Node;
   --  Return the number of items in the Node sequence/mapping

   function Item (Node : Node_Ref; Index : Positive) return Node_Ref
      with Pre => Kind (Node) = Sequence_Node
                  and then Index <= Length (Node);
   --  Return the Index'th item in Node. Index is 1-based.

   type Node_Pair is record
      Key, Value : Node_Ref;
   end record;
   --  Key/value asssociation in a mapping node

   function Item (Node : Node_Ref; Index : Positive) return Node_Pair
      with Pre => Kind (Node) = Mapping_Node
                  and then Index <= Length (Node);
   --  Return the Index'th key/value association in Node. Index is 1-based.

   function Item (Node : Node_Ref; Key : UTF8_String) return Node_Ref
      with Pre => Kind (Node) = Mapping_Node;
   --  Look for Key in the Node mapping. If there is one, return the
   --  corresponding Value. Return No_Node_Ref otherwise.

   type Parser_Type is tagged limited private;
   --  YAML document parser

   type Encoding_Type is
     (Any_Encoding,
      --  Let the parser choose the encoding

      UTF8_Encoding,
      --  The default UTF-8 encoding

      UTF16LE_Encoding,
      --  The UTF-16-LE encoding with BOM

      UTF16BE_Encoding
      --  The UTF-16-BE encoding with BOM
     ) with
      Convention => C;
   --  Stream encoding

   procedure Set_Input_String
     (Parser   : in out Parser_Type'Class;
      Input    : String;
      Encoding : Encoding_Type);
   --  Set a string input. This maintains a copy of Input in Parser.

   File_Error : exception;
   --  Exception raised when file-related errors occurs. For instance: cannot
   --  open a file, cannot read a file, etc.

   procedure Set_Input_File
     (Parser   : in out Parser_Type'Class;
      Filename : String;
      Encoding : Encoding_Type);
   --  Set a file input. This opens Filename until the parser is destroyed or
   --  until another Set_Input_* procedure is successfuly called. If an error
   --  occurs while opening the file, raise a File_Error and leave the parser
   --  unmodified.

   function Load (Parser : in out Parser_Type'Class) return Document_Type;
   --  Parse the input stream and produce the next YAML document.
   --
   --  Call this function subsequently to produce a sequence of documents
   --  constituting the input stream. If the produced document has no root
   --  node, it means that the document end has been reached.
   --
   --  TODO: error handling

private

   subtype C_Int is Interfaces.C.int;
   subtype C_Index is C_Int range 0 .. C_Int'Last;
   subtype C_Ptr_Diff is Interfaces.C.ptrdiff_t;

   type C_Char_Array is array (C_Index) of Interfaces.Unsigned_8;
   type C_Char_Access is access all C_Char_Array;

   type C_Node_T;
   type C_Node_Access is access all C_Node_T;

   type C_Scalar_Style_T is
     (Any_Scalar_Style,
      Plain_Scalar_Style,
      Single_Quoted_Scalar_Style,
      Double_Quoted_Scalar_Style,
      Literal_Scalar_Style,
      Folded_Scalar_Style) with
      Convention => C;
   --  Scalar styles

   type C_Sequence_Style_T is
     (Any_Sequence_Style,
      Block_Sequence_Style,
      Flow_Sequence_Style) with
      Convention => C;
   --  Sequence styles

   type C_Mapping_Style_T is
     (Any_Mapping_Style,
      Block_Mapping_Style,
      Flow_Mapping_Style) with
      Convention => C;
   --  Mapping styles

   type C_Mark_T is record
      Index, Line, Column : Interfaces.C.size_t;
   end record with
      Convention => C_Pass_By_Copy;
   --  The pointer position

   type C_Version_Directive_T is record
      Major, Minor : C_Int;
      --  Major and minor version numbers
   end record with
      Convention => C_Pass_By_Copy;
   --  The version directive data

   type C_Version_Directive_Access is access all C_Version_Directive_T;

   type C_Tag_Directive_T is record
      Handle : C_Char_Access;
      --  The tag handle

      Prefix : C_Char_Access;
      --  The tag prefix
   end record with
      Convention => C_Pass_By_Copy;
   --  The tag directive data

   type C_Tag_Directive_Access is access C_Tag_Directive_T;

   subtype C_Node_Item_T is C_Int;
   type C_Node_Item_Array is array (C_Index range <>) of aliased C_Node_Item_T;
   package C_Node_Item_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Item_T,
      Element_Array      => C_Node_Item_Array,
      Default_Terminator => -1);
   subtype C_Node_Item_Access is C_Node_Item_Accesses.Pointer;

   type C_Node_Pair_T is record
      Key, Value : C_Int;
   end record with
      Convention => C_Pass_By_Copy;
   type C_Node_Pair_Array is array (C_Index range <>) of aliased C_Node_Pair_T;
   package C_Node_Pair_Accesses is new Interfaces.C.Pointers
     (Index              => C_Index,
      Element            => C_Node_Pair_T,
      Element_Array      => C_Node_Pair_Array,
      Default_Terminator => (-1, -1));
   subtype C_Node_Pair_Access is C_Node_Pair_Accesses.Pointer;

   ----------------------------
   -- Node structure binding --
   ----------------------------

   type C_Scalar_Node_Data is record
      Value  : C_Char_Access;
      --  The scalar value

      Length : Interfaces.C.size_t;
      --  The length of the scalar value

      Style  : C_Scalar_Style_T;
      --  The scalar style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Items is record
      Seq_Start, Seq_End, Seq_Top : C_Node_Item_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Sequence_Node_Data is record
      Items : C_Sequence_Items;
      --  The stack of sequence items

      Style : C_Sequence_Style_T;
      --  The sequence style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Pairs is record
      Map_Start, Map_End, Map_Top : C_Node_Pair_Access;
   end record with
      Convention => C_Pass_By_Copy;

   type C_Mapping_Node_Data is record
      Pairs : C_Mapping_Pairs;
      --  The stack of mapping pairs

      Style : C_Mapping_Style_T;
      --  The mapping style
   end record with
      Convention => C_Pass_By_Copy;

   type C_Node_Data (Dummy : Node_Kind := No_Node) is record
      case Dummy is
         when No_Node =>
            null;

         when Scalar_Node =>
            Scalar : C_Scalar_Node_Data;
            --  The scalar parameters (for Scalar_Node)

         when Sequence_Node =>
            Sequence : C_Sequence_Node_Data;
            --  The sequence parameters (for Sequence_Node)

         when Mapping_Node =>
            Mapping : C_Mapping_Node_Data;
            --  The mapping parameters (for Mapping_Node)
      end case;
   end record with
      Convention => C_Pass_By_Copy,
      Unchecked_Union;

   type C_Node_T is record
      Kind : Node_Kind;
      --  The node type

      Tag  : C_Char_Access;
      --  The node tag

      Data : C_Node_Data;
      --  The node data

      Start_Mark, End_Mark : C_Mark_T;
   end record with
      Convention => C_Pass_By_Copy;

   --------------------------------
   -- Document structure binding --
   --------------------------------

   type C_Document_Nodes is record
      Start_Node, End_Node, Top_Node : C_Node_T;
      --  Begining, end and top of the stack
   end record with
      Convention => C_Pass_By_Copy;

   type C_Tag_Directives is record
      Start_Dir, End_Dir : C_Tag_Directive_Access;
      --  Beginning and end of the tag directives list
   end record with
      Convention => C_Pass_By_Copy;

   type C_Document_T is record
      Nodes                        : C_Document_Nodes;
      --  The document nodes

      Version_Directives           : C_Version_Directive_Access;
      --  The version directive

      Tag_Directives               : C_Tag_Directives;
      --  The list of tag directives

      Start_Implicit, End_Implicit : C_Int;
      --  Is the document start/end indicator explicit?

      Start_Mark, End_Mark         : C_Mark_T;
      --  Beginning and end of the document
   end record with
      Convention => C_Pass_By_Copy;
   --  The document structure

   type C_Document_Access is access all C_Document_T;

   -------------------------
   -- High-level Wrappers --
   -------------------------

   type Document_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Doc     : aliased C_Document_T;
      To_Delete : Boolean;
   end record;

   overriding procedure Initialize (Document : in out Document_Type);
   overriding procedure Finalize (Document : in out Document_Type);

   type Document_Access is access all Document_Type'Class;

   type Node_Ref is record
      Node     : C_Node_Access;
      --  The referenced node

      Document : Document_Access;
      --  The document it belongs to
   end record;

   No_Node_Ref : constant Node_Ref := (null, null);

   type C_Parser_Access is new System.Address;
   type String_Access is access String;

   type C_File_Ptr is new System.Address;
   No_File_Ptr : constant C_File_Ptr := C_File_Ptr (System.Null_Address);

   type Parser_Type is limited new Ada.Finalization.Limited_Controlled
   with record
      C_Parser       : C_Parser_Access;
      Input_Encoding : Encoding_Type;
      Input_String   : String_Access;
      Input_File     : C_File_Ptr;
   end record;

   overriding procedure Initialize (Parser : in out Parser_Type);
   overriding procedure Finalize (Parser : in out Parser_Type);

end YAML;

Add Index range checks in YAML.Item preconditions


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      return False;
   end Has_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use type Permissions.Permission_Index;
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

Implement Has_Permission

Implement Has_Permission


-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

end AWA.Blogs.Beans;

-----------------------------------------------------------------------
--  awa-blogs-beans -- Beans for blog module
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
with AWA.Tags.Beans;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";
   POST_TAG_ATTR      : constant String := "tags";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;

      --  List of tags associated with the post.
      Tags      : aliased AWA.Tags.Beans.Tag_List_Bean;
      Tags_Bean : Util.Beans.Basic.Readonly_Bean_Access;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_Admin_Bean bean instance.
   function Create_Blog_Admin_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   type Init_Flag is (INIT_BLOG_LIST, INIT_POST_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   type Blog_Admin_Bean is new Util.Beans.Basic.Bean with record
      Module : AWA.Blogs.Modules.Blog_Module_Access := null;

      --  The blog identifier.
      Blog_Id          : ADO.Identifier := ADO.NO_IDENTIFIER;

      --  List of blogs.
      Blog_List        : aliased AWA.Blogs.Models.Blog_Info_List_Bean;
      Blog_List_Bean   : AWA.Blogs.Models.Blog_Info_List_Bean_Access;

      --  List of posts.
      Post_List        : aliased AWA.Blogs.Models.Admin_Post_Info_List_Bean;
      Post_List_Bean   : AWA.Blogs.Models.Admin_Post_Info_List_Bean_Access;

      --  Initialization flags.
      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Blog_Admin_Bean_Access is access all Blog_Admin_Bean;

   --  Get the blog identifier.
   function Get_Blog_Id (List : in Blog_Admin_Bean) return ADO.Identifier;

   --  Load the posts associated with the current blog.
   procedure Load_Posts (List : in Blog_Admin_Bean);

   overriding
   function Get_Value (List : in Blog_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the list of blogs.
   procedure Load_Blogs (List : in Blog_Admin_Bean);

end AWA.Blogs.Beans;

Add a list of tags to the post

Add a list of tags to the post


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

with ADO.Testsuite;
with ADO.Drivers;
with Regtests;

with Util.Tests;
with Util.Properties;
procedure ADO_Harness is

   procedure Initialize (Props : in Util.Properties.Manager);

   procedure Harness is new Util.Tests.Harness (ADO.Testsuite.Suite,
                                               Initialize);

   --  ------------------------------
   --  Initialization procedure: setup the database
   --  ------------------------------
   procedure Initialize (Props : in Util.Properties.Manager) is
      DB : constant String := Props.Get ("test.database",
                                         "sqlite:///regtests.db");
   begin
      ADO.Drivers.Initialize;
      Regtests.Initialize (DB);
   end Initialize;

begin
   Harness ("ado-tests.xml");
end ADO_Harness;

-----------------------------------------------------------------------
--  ADO Databases -- Database Objects
--  Copyright (C) 2009, 2010, 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.Testsuite;
with ADO.Drivers.Initializer;
with Regtests;

with Util.Tests;
with Util.Properties;
procedure ADO_Harness is

   procedure Initialize (Props : in Util.Properties.Manager);

   procedure Harness is new Util.Tests.Harness (ADO.Testsuite.Suite,
                                               Initialize);

   procedure Init_Drivers is new ADO.Drivers.Initializer (Util.Properties.Manager'Class,
                                                          ADO.Drivers.Initialize);

   --  ------------------------------
   --  Initialization procedure: setup the database
   --  ------------------------------
   procedure Initialize (Props : in Util.Properties.Manager) is
      DB : constant String := Props.Get ("test.database",
                                         "sqlite:///regtests.db");
   begin
      Init_Drivers (Props);
      Regtests.Initialize (DB);
   end Initialize;

begin
   Harness ("ado-tests.xml");
end ADO_Harness;

Initialize the database drivers

Initialize the database drivers


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

package Gen.Commands.Info is

   --  ------------------------------
   --  Project Information Command
   --  ------------------------------
   --  This command collects information about the project and print it.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Info;

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

package Gen.Commands.Info is

   --  ------------------------------
   --  Project Information Command
   --  ------------------------------
   --  This command collects information about the project and print it.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Info;

Update to use the new command implementation


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

--  == User database ==
--  The <tt>Babel.Base.Users</tt> package defines a small database that maintains the
--  mapping between a user or group name and the user <tt>uid_t</tt> or group <tt>gid_t</tt>.
--  The mapping is obtained by using the Posix.1-2001 operations getpwnam_r (3) and
--  getgrnam_r (3).  The Posix operations are called once for a given name/id and they are
--  stored in several hash map.  A protected type is used to maintain the user and group
--  mapping cache so that concurrent accesses are possible.
package Babel.Base.Users is

   subtype Name_Access is Util.Strings.Name_Access;

   --  Information about a user and its group.
   type User_Type is record
      Name  : Name_Access;
      Group : Name_Access;
      Uid   : Uid_Type;
      Gid   : Gid_Type;
   end record;

   NO_USER : constant User_Type;

   type Database is tagged limited private;
   type Database_Access is access all Database'Class;

   --  Find the UID and GID for the user that corresponds to the given name and group.
   function Find (From  : in Database;
                  Name  : in String;
                  Group : in String) return User_Type;

   --  Find the UID and GID for the user that corresponds to the given name and group.
   function Find (From  : in Database;
                  Name  : in Uid_Type;
                  Group : in Gid_Type) return User_Type;

   --  Get the user name associated with the given UID.
   --  Returns null if the UID was not found.
   function Get_Name (From : in Database;
                      Id   : in Uid_Type) return Name_Access;

   --  Get the UID associated with the given user name.
   function Get_Uid (From : in Database;
                     Name : in String) return Uid_Type;

   --  Get the group name associated with the given GID.
   --  Returns null if the GID was not found.
   function Get_Group (From : in Database;
                       Id   : in Gid_Type) return Name_Access;

   --  Get the GID associated with the given group name.
   function Get_Gid (From : in Database;
                     Name : in String) return Gid_Type;

private

   INVALID_ID : constant Natural := Natural'Last;

   NO_USER : constant User_Type := User_Type'(Name  => null,
                                              Group => null,
                                              Uid   => Uid_Type'Last,
                                              Gid   => Gid_Type'Last);

   function Hash (Key : in Natural) return Ada.Containers.Hash_Type;

   package Id_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Natural,
                                     Element_Type    => Name_Access,
                                     Hash            => Hash,
                                     Equivalent_Keys => "=",
                                     "="             => Util.Strings."=");

   package Name_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Name_Access,
                                     Element_Type    => Natural,
                                     Hash            => Util.Strings.Hash,
                                     Equivalent_Keys => Util.Strings.Equivalent_Keys,
                                     "="             => "=");

   --  To keep the implementation simple, the same protected type and same hash maps
   --  is used for the users and groups database.
   protected type Local_Base is

      --  Find in the ID map for the associated user/group name.
      --  If the item is not found in the map, call the <tt>Search</tt> function to resolve it.
      --  If the ID was not found, return a null name.
      procedure Find_Name (Id     : in Natural;
                           Search : not null access function (Id : in Natural) return String;
                           Name   : out Name_Access);

      --  Find in the name map for the corresponding ID.
      --  If the name was not found in the map, call the <tt>Search</tt> function to resolve it.
      procedure Find_Id (Name   : in String;
                         Search : not null access function (Name : in String) return Natural;
                         Id     : out Natural);

      procedure Clear;

   private
      Names : Name_Map.Map;
      Ids   : Id_Map.Map;
   end Local_Base;

   type Database is limited new Ada.Finalization.Limited_Controlled with record
      User_Base  : aliased Local_Base;
      Group_Base : aliased Local_Base;
      Users      : access Local_Base;
      Groups     : access Local_Base;
   end record;

   overriding
   procedure Initialize (Db : in out Database);

   overriding
   procedure Finalize (Db : in out Database);

end Babel.Base.Users;

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

--  == User database ==
--  The <tt>Babel.Base.Users</tt> package defines a small database that maintains the
--  mapping between a user or group name and the user <tt>uid_t</tt> or group <tt>gid_t</tt>.
--  The mapping is obtained by using the Posix.1-2001 operations getpwnam_r (3) and
--  getgrnam_r (3).  The Posix operations are called once for a given name/id and they are
--  stored in several hash map.  A protected type is used to maintain the user and group
--  mapping cache so that concurrent accesses are possible.
package Babel.Base.Users is

   subtype Name_Access is Util.Strings.Name_Access;

   --  Information about a user and its group.
   type User_Type is record
      Name  : Name_Access;
      Group : Name_Access;
      Uid   : Uid_Type;
      Gid   : Gid_Type;
   end record;

   NO_USER : constant User_Type;

   type Database is tagged limited private;
   type Database_Access is access all Database'Class;

   --  Find the UID and GID for the user that corresponds to the given name and group.
   function Find (From  : in Database;
                  User  : in String;
                  Group : in String) return User_Type;

   --  Find the UID and GID for the user that corresponds to the given name and group.
   function Find (From  : in Database;
                  User  : in Uid_Type;
                  Group : in Gid_Type) return User_Type;

   --  Get the user name associated with the given UID.
   --  Returns null if the UID was not found.
   function Get_Name (From : in Database;
                      Id   : in Uid_Type) return Name_Access;

   --  Get the UID associated with the given user name.
   function Get_Uid (From : in Database;
                     Name : in String) return Uid_Type;

   --  Get the group name associated with the given GID.
   --  Returns null if the GID was not found.
   function Get_Group (From : in Database;
                       Id   : in Gid_Type) return Name_Access;

   --  Get the GID associated with the given group name.
   function Get_Gid (From : in Database;
                     Name : in String) return Gid_Type;

private

   INVALID_ID : constant Natural := Natural'Last;

   NO_USER : constant User_Type := User_Type'(Name  => null,
                                              Group => null,
                                              Uid   => Uid_Type'Last,
                                              Gid   => Gid_Type'Last);

   function Hash (Key : in Natural) return Ada.Containers.Hash_Type;

   package Id_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Natural,
                                     Element_Type    => Name_Access,
                                     Hash            => Hash,
                                     Equivalent_Keys => "=",
                                     "="             => Util.Strings."=");

   package Name_Map is
     new Ada.Containers.Hashed_Maps (Key_Type        => Name_Access,
                                     Element_Type    => Natural,
                                     Hash            => Util.Strings.Hash,
                                     Equivalent_Keys => Util.Strings.Equivalent_Keys,
                                     "="             => "=");

   --  To keep the implementation simple, the same protected type and same hash maps
   --  is used for the users and groups database.
   protected type Local_Base is

      --  Find in the ID map for the associated user/group name.
      --  If the item is not found in the map, call the <tt>Search</tt> function to resolve it.
      --  If the ID was not found, return a null name.
      procedure Find_Name (Id     : in Natural;
                           Search : not null access function (Id : in Natural) return String;
                           Name   : out Name_Access);

      --  Find in the name map for the corresponding ID.
      --  If the name was not found in the map, call the <tt>Search</tt> function to resolve it.
      procedure Find_Id (Name   : in String;
                         Search : not null access function (Name : in String) return Natural;
                         Id     : out Natural;
                         Result : out Name_Access);

      procedure Clear;

   private
      Names : Name_Map.Map;
      Ids   : Id_Map.Map;
   end Local_Base;

   type Database is limited new Ada.Finalization.Limited_Controlled with record
      User_Base  : aliased Local_Base;
      Group_Base : aliased Local_Base;
      Users      : access Local_Base;
      Groups     : access Local_Base;
   end record;

   overriding
   procedure Initialize (Db : in out Database);

   overriding
   procedure Finalize (Db : in out Database);

end Babel.Base.Users;

Update the declaration of Find and Find_Id operations


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

--  This is a small HTML parser that is called to deal with embedded HTML in wiki text.
--  The parser is intended to handle incorrect HTML and clean the result as much as possible.
--  We cannot use a real XML/Sax parser (such as XML/Ada) because we must handle errors and
--  backtrack from HTML parsing to wiki or raw text parsing.
--
--  When parsing HTML content, we call the <tt>Start_Element</tt> or <tt>End_Element</tt>
--  operations.  The renderer is then able to handle the HTML tag according to its needs.
private package Wiki.Parsers.Html is

   pragma Preelaborate;

   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   procedure Parse_Element (P : in out Parser);

   --  Parse an HTML entity such as   and replace it with the corresponding code.
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wide_Wide_Character);

end Wiki.Parsers.Html;

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

--  This is a small HTML parser that is called to deal with embedded HTML in wiki text.
--  The parser is intended to handle incorrect HTML and clean the result as much as possible.
--  We cannot use a real XML/Sax parser (such as XML/Ada) because we must handle errors and
--  backtrack from HTML parsing to wiki or raw text parsing.
--
--  When parsing HTML content, we call the <tt>Start_Element</tt> or <tt>End_Element</tt>
--  operations.  The renderer is then able to handle the HTML tag according to its needs.
private package Wiki.Parsers.Html is

   pragma Preelaborate;

   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   procedure Parse_Element (P : in out Parser);

   --  Parse an HTML entity such as   and replace it with the corresponding code.
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar);

end Wiki.Parsers.Html;

Use the Wiki.Strings.UString type and operations


-----------------------------------------------------------------------
--  util-beans-objects-datasets -- Datasets
--  Copyright (C) 2013, 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 Ada.Unchecked_Deallocation;

package body Util.Beans.Objects.Datasets is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Object_Array,
                                      Name   => Object_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Dataset_Array,
                                     Name   => Dataset_Array_Access);

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Dataset) return Natural is
   begin
      return From.Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Dataset;
                            Index : in Natural) is
   begin
      From.Current_Pos  := Index;
      From.Current.Data := From.Data (Index);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Dataset) return Util.Beans.Objects.Object is
   begin
      return From.Row;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Dataset;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Current_Pos);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get an iterator to iterate starting with the first element.
   --  ------------------------------
   overriding
   function First (From : in Dataset) return Iterators.Proxy_Iterator_Access is
      Iter : constant Dataset_Iterator_Access := new Dataset_Iterator;
   begin
      Iter.Current_Pos  := 1;
      Iter.Current.Map := From.Current.Map;
      if From.Count > 0 then
         Iter.Current.Data := From.Data (1);
      end if;
      return Iter.all'Access;
   end First;

   --  ------------------------------
   --  Get an iterator to iterate starting with the last element.
   --  ------------------------------
   overriding
   function Last (From : in Dataset) return Iterators.Proxy_Iterator_Access is
      Iter : constant Dataset_Iterator_Access := new Dataset_Iterator;
   begin
      Iter.Current_Pos  := From.Count;
      Iter.Current.Map := From.Current.Map;
      if From.Count > 0 then
         Iter.Current.Data := From.Data (From.Count);
      end if;
      return Iter.all'Access;
   end Last;

   --  ------------------------------
   --  Append a row in the dataset and call the fill procedure to populate
   --  the row content.
   --  ------------------------------
   procedure Append (Into : in out Dataset;
                     Fill : not null access procedure (Data : in out Object_Array)) is
      Data : constant Object_Array_Access := new Object_Array (1 .. Into.Columns);
   begin
      if Into.Data = null then
         Into.Data := new Dataset_Array (1 .. 10);
      elsif Into.Count >= Into.Data'Length then
         declare
            --  Sun's Java ArrayList use a 2/3 grow factor.
            --  Python's array use 8/9.
            Grow : constant Positive := Into.Count + (Into.Count * 2) / 3;
            Set  : constant Dataset_Array_Access := new Dataset_Array (1 .. Grow);
         begin
            Set (Into.Data'Range) := Into.Data.all;
            Free (Into.Data);
            Into.Data := Set;
         end;
      end if;
      Into.Count := Into.Count + 1;
      Into.Data (Into.Count) := Data;
      Fill (Data.all);
   end Append;

   --  ------------------------------
   --  Add a column to the dataset.  If the position is not specified,
   --  the column count is incremented and the name associated with the last column.
   --  Raises Invalid_State exception if the dataset contains some rows,
   --  ------------------------------
   procedure Add_Column (Into : in out Dataset;
                         Name : in String;
                         Pos  : in Natural := 0) is
      Col : Positive;
   begin
      if Into.Count /= 0 then
         raise Invalid_State with "The dataset contains some rows.";
      end if;
      if Pos = 0 then
         Col := Into.Columns + 1;
      else
         Col := Pos;
      end if;
      Into.Map.Insert (Name, Col);
      if Into.Columns < Col then
         Into.Columns := Col;
      end if;
   end Add_Column;

   --  ------------------------------
   --  Clear the content of the dataset.
   --  ------------------------------
   procedure Clear (Set : in out Dataset) is
   begin
      for I in 1 .. Set.Count loop
         Free (Set.Data (I));
      end loop;
      Set.Count        := 0;
      Set.Current_Pos  := 0;
      Set.Current.Data := null;
   end Clear;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Row;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         return From.Data (Dataset_Map.Element (Pos));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Row;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         From.Data (Dataset_Map.Element (Pos)) := Value;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Get an iterator to iterate starting with the first element.
   --  ------------------------------
   overriding
   function First (From : in Row) return Iterators.Proxy_Iterator_Access is
      Iter : constant Row_Iterator_Access := new Row_Iterator;
   begin
      Iter.Pos := From.Map.First;
      Iter.Data := From.Data;
      return Iter.all'Access;
   end First;

   --  ------------------------------
   --  Get an iterator to iterate starting with the last element.
   --  ------------------------------
   overriding
   function Last (From : in Row) return Iterators.Proxy_Iterator_Access is
   begin
      return null;
   end Last;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Set : in out Dataset) is
   begin
      Set.Row := To_Object (Value   => Set.Current'Unchecked_Access,
                            Storage => STATIC);
      Set.Current.Map := Set.Map'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Release the dataset storage.
   --  ------------------------------
   overriding
   procedure Finalize (Set : in out Dataset) is
   begin
      Set.Clear;
      Free (Set.Data);
   end Finalize;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Iter : in out Dataset_Iterator) is
   begin
      Iter.Row := To_Object (Value   => Iter.Current'Unchecked_Access,
                             Storage => STATIC);
   end Initialize;

   function Get_Dataset is
      new Util.Beans.Objects.Iterators.Get_Bean (Dataset, Dataset_Access);

   overriding
   function Has_Element (Iter : in Dataset_Iterator) return Boolean is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      return List /= null and then Iter.Current_Pos /= 0
        and then Iter.Current_Pos <= List.Count;
   end Has_Element;

   overriding
   procedure Next (Iter : in out Dataset_Iterator) is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      if List /= null and then Iter.Current_Pos <= List.Count then
         Iter.Current_Pos := Iter.Current_Pos + 1;
         if Iter.Current_Pos <= List.Count then
            Iter.Current.Data := List.Data (Iter.Current_Pos);
         end if;
      end if;
   end Next;

   overriding
   procedure Previous (Iter : in out Dataset_Iterator) is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      if List /= null and then Iter.Current_Pos > 0 then
         Iter.Current_Pos := Iter.Current_Pos - 1;
         if Iter.Current_Pos > 0 then
            Iter.Current.Data := List.Data (Iter.Current_Pos);
         end if;
      end if;
   end Previous;

   overriding
   function Element (Iter : in Dataset_Iterator) return Object is
   begin
      return Iter.Row;
   end Element;

   overriding
   procedure Initialize (Iter : in out Row_Iterator) is
   begin
      null;
   end Initialize;

   overriding
   function Has_Element (Iter : in Row_Iterator) return Boolean is
   begin
      return Dataset_Map.Has_Element (Iter.Pos);
   end Has_Element;

   overriding
   procedure Next (Iter : in out Row_Iterator) is
   begin
      Dataset_Map.Next (Iter.Pos);
   end Next;

   overriding
   procedure Previous (Iter : in out Row_Iterator) is
   begin
      null;
   end Previous;

   overriding
   function Element (Iter : in Row_Iterator) return Object is
   begin
      return Iter.Data (Dataset_Map.Element (Iter.Pos));
   end Element;

   overriding
   function Key (Iter : in Row_Iterator) return String is
   begin
      return Dataset_Map.Key (Iter.Pos);
   end Key;

end Util.Beans.Objects.Datasets;

-----------------------------------------------------------------------
--  util-beans-objects-datasets -- Datasets
--  Copyright (C) 2013, 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 Ada.Unchecked_Deallocation;

package body Util.Beans.Objects.Datasets is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Object_Array,
                                      Name   => Object_Array_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Dataset_Array,
                                     Name   => Dataset_Array_Access);

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : in Dataset) return Natural is
   begin
      return From.Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out Dataset;
                            Index : in Natural) is
   begin
      From.Current_Pos  := Index;
      From.Current.Data := From.Data (Index);
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : in Dataset) return Util.Beans.Objects.Object is
   begin
      return From.Row;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Dataset;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "count" then
         return Util.Beans.Objects.To_Object (From.Count);
      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Current_Pos);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get an iterator to iterate starting with the first element.
   --  ------------------------------
   overriding
   function First (From : in Dataset) return Iterators.Proxy_Iterator_Access is
      Iter : constant Dataset_Iterator_Access := new Dataset_Iterator;
   begin
      Iter.Current_Pos  := 1;
      Iter.Current.Map := From.Current.Map;
      if From.Count > 0 then
         Iter.Current.Data := From.Data (1);
      end if;
      return Iter.all'Access;
   end First;

   --  ------------------------------
   --  Get an iterator to iterate starting with the last element.
   --  ------------------------------
   overriding
   function Last (From : in Dataset) return Iterators.Proxy_Iterator_Access is
      Iter : constant Dataset_Iterator_Access := new Dataset_Iterator;
   begin
      Iter.Current_Pos  := From.Count;
      Iter.Current.Map := From.Current.Map;
      if From.Count > 0 then
         Iter.Current.Data := From.Data (From.Count);
      end if;
      return Iter.all'Access;
   end Last;

   --  ------------------------------
   --  Append a row in the dataset and call the fill procedure to populate
   --  the row content.
   --  ------------------------------
   procedure Append (Into : in out Dataset;
                     Fill : not null access procedure (Data : in out Object_Array)) is
      Data : constant Object_Array_Access := new Object_Array (1 .. Into.Columns);
   begin
      if Into.Data = null then
         Into.Data := new Dataset_Array (1 .. 10);
      elsif Into.Count >= Into.Data'Length then
         declare
            --  Sun's Java ArrayList use a 2/3 grow factor.
            --  Python's array use 8/9.
            Grow : constant Positive := Into.Count + (Into.Count * 2) / 3;
            Set  : constant Dataset_Array_Access := new Dataset_Array (1 .. Grow);
         begin
            Set (Into.Data'Range) := Into.Data.all;
            Free (Into.Data);
            Into.Data := Set;
         end;
      end if;
      Into.Count := Into.Count + 1;
      Into.Data (Into.Count) := Data;
      Fill (Data.all);
   end Append;

   --  ------------------------------
   --  Add a column to the dataset.  If the position is not specified,
   --  the column count is incremented and the name associated with the last column.
   --  Raises Invalid_State exception if the dataset contains some rows,
   --  ------------------------------
   procedure Add_Column (Into : in out Dataset;
                         Name : in String;
                         Pos  : in Natural := 0) is
      Col : Positive;
   begin
      if Into.Count /= 0 then
         raise Invalid_State with "The dataset contains some rows.";
      end if;
      if Pos = 0 then
         Col := Into.Columns + 1;
      else
         Col := Pos;
      end if;
      Into.Map.Insert (Name, Col);
      if Into.Columns < Col then
         Into.Columns := Col;
      end if;
   end Add_Column;

   --  ------------------------------
   --  Clear the content of the dataset.
   --  ------------------------------
   procedure Clear (Set : in out Dataset) is
   begin
      for I in 1 .. Set.Count loop
         Free (Set.Data (I));
      end loop;
      Set.Count        := 0;
      Set.Current_Pos  := 0;
      Set.Current.Data := null;
   end Clear;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Row;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         return From.Data (Dataset_Map.Element (Pos));
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Row;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Pos : constant Dataset_Map.Cursor := From.Map.Find (Name);
   begin
      if From.Data /= null and then Dataset_Map.Has_Element (Pos) then
         From.Data (Dataset_Map.Element (Pos)) := Value;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Get an iterator to iterate starting with the first element.
   --  ------------------------------
   overriding
   function First (From : in Row) return Iterators.Proxy_Iterator_Access is
      Iter : constant Row_Iterator_Access := new Row_Iterator;
   begin
      Iter.Pos := From.Map.First;
      Iter.Data := From.Data;
      return Iter.all'Access;
   end First;

   --  ------------------------------
   --  Get an iterator to iterate starting with the last element.
   --  ------------------------------
   overriding
   function Last (From : in Row) return Iterators.Proxy_Iterator_Access is
      pragma Unreferenced (From);
   begin
      return null;
   end Last;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Set : in out Dataset) is
   begin
      Set.Row := To_Object (Value   => Set.Current'Unchecked_Access,
                            Storage => STATIC);
      Set.Current.Map := Set.Map'Unchecked_Access;
   end Initialize;

   --  ------------------------------
   --  Release the dataset storage.
   --  ------------------------------
   overriding
   procedure Finalize (Set : in out Dataset) is
   begin
      Set.Clear;
      Free (Set.Data);
   end Finalize;

   --  ------------------------------
   --  Initialize the dataset and the row bean instance.
   --  ------------------------------
   overriding
   procedure Initialize (Iter : in out Dataset_Iterator) is
   begin
      Iter.Row := To_Object (Value   => Iter.Current'Unchecked_Access,
                             Storage => STATIC);
   end Initialize;

   function Get_Dataset is
      new Util.Beans.Objects.Iterators.Get_Bean (Dataset, Dataset_Access);

   overriding
   function Has_Element (Iter : in Dataset_Iterator) return Boolean is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      return List /= null and then Iter.Current_Pos /= 0
        and then Iter.Current_Pos <= List.Count;
   end Has_Element;

   overriding
   procedure Next (Iter : in out Dataset_Iterator) is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      if List /= null and then Iter.Current_Pos <= List.Count then
         Iter.Current_Pos := Iter.Current_Pos + 1;
         if Iter.Current_Pos <= List.Count then
            Iter.Current.Data := List.Data (Iter.Current_Pos);
         end if;
      end if;
   end Next;

   overriding
   procedure Previous (Iter : in out Dataset_Iterator) is
      List : constant Dataset_Access := Get_Dataset (Iter);
   begin
      if List /= null and then Iter.Current_Pos > 0 then
         Iter.Current_Pos := Iter.Current_Pos - 1;
         if Iter.Current_Pos > 0 then
            Iter.Current.Data := List.Data (Iter.Current_Pos);
         end if;
      end if;
   end Previous;

   overriding
   function Element (Iter : in Dataset_Iterator) return Object is
   begin
      return Iter.Row;
   end Element;

   overriding
   procedure Initialize (Iter : in out Row_Iterator) is
   begin
      null;
   end Initialize;

   overriding
   function Has_Element (Iter : in Row_Iterator) return Boolean is
   begin
      return Dataset_Map.Has_Element (Iter.Pos);
   end Has_Element;

   overriding
   procedure Next (Iter : in out Row_Iterator) is
   begin
      Dataset_Map.Next (Iter.Pos);
   end Next;

   overriding
   procedure Previous (Iter : in out Row_Iterator) is
   begin
      null;
   end Previous;

   overriding
   function Element (Iter : in Row_Iterator) return Object is
   begin
      return Iter.Data (Dataset_Map.Element (Iter.Pos));
   end Element;

   overriding
   function Key (Iter : in Row_Iterator) return String is
   begin
      return Dataset_Map.Key (Iter.Pos);
   end Key;

end Util.Beans.Objects.Datasets;

Fix compilation warning

Fix compilation warning