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

with MAT.Targets;
package MAT.Commands is

   Stop_Interp : exception;

   --  Procedure that defines a command handler.
   type Command_Handler is access procedure (Target : in out MAT.Targets.Target_Type'Class;
                                             Args   : in String);

   --  Execute the command given in the line.
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String);

   --  Initialize the process targets by loading the MAT files.
   procedure Initialize_Files (Target  : in out MAT.Targets.Target_Type'Class);

   --  Symbol command.
   --  Load the symbols from the binary file.
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

   --  Threads command.
   --  Collect statistics about the threads and their allocation.
   procedure Threads_Command (Target : in out MAT.Targets.Target_Type'Class;
                              Args   : in String);

   --  Events command.
   --  Print the probe events.
   procedure Events_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Event command.
   --  Print the probe event with the stack frame.
   procedure Event_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

end MAT.Commands;

-----------------------------------------------------------------------
--  mat-commands -- Command support and execution
--  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.
-----------------------------------------------------------------------

with MAT.Targets;
package MAT.Commands is

   Stop_Interp : exception;

   --  Procedure that defines a command handler.
   type Command_Handler is access procedure (Target : in out MAT.Targets.Target_Type'Class;
                                             Args   : in String);

   --  Execute the command given in the line.
   procedure Execute (Target : in out MAT.Targets.Target_Type'Class;
                      Line   : in String);

   --  Initialize the process targets by loading the MAT files.
   procedure Initialize_Files (Target  : in out MAT.Targets.Target_Type'Class);

   --  Symbol command.
   --  Load the symbols from the binary file.
   procedure Symbol_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Sizes command.
   --  Collect statistics about the used memory slots and report the different slot
   --  sizes with count.
   procedure Sizes_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

   --  Threads command.
   --  Collect statistics about the threads and their allocation.
   procedure Threads_Command (Target : in out MAT.Targets.Target_Type'Class;
                              Args   : in String);

   --  Events command.
   --  Print the probe events.
   procedure Events_Command (Target : in out MAT.Targets.Target_Type'Class;
                             Args   : in String);

   --  Event command.
   --  Print the probe event with the stack frame.
   procedure Event_Command (Target : in out MAT.Targets.Target_Type'Class;
                            Args   : in String);

   --  Info command to print symmary information about the program.
   procedure Info_Command (Target : in out MAT.Targets.Target_Type'Class;
                           Args   : in String);

end MAT.Commands;

Declare the Info_Command procedure

Declare the Info_Command procedure


-----------------------------------------------------------------------
--  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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Policy is new Ada.Finalization.Limited_Controlled with null record;
   type Policy_Access is access all Policy'Class;

   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser) is null;

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

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permissions.Permission_Index range <>) of Controller_Access;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  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;
   pragma Inline_Always (Get_Controller);

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

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

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   use Util.Strings;

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Manager is new Ada.Finalization.Limited_Controlled with record
--        Cache        : Rules_Ref_Access;
--        Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Policy is new Ada.Finalization.Limited_Controlled with null record;
   type Policy_Access is access all Policy'Class;

   procedure Set_Reader_Config (Pol     : in out Policy;
                                Reader  : in out Util.Serialize.IO.XML.Parser) is null;

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

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permissions.Permission_Index range <>) of Controller_Access;

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  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);

   --  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;
   pragma Inline_Always (Get_Controller);

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

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

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   use Util.Strings;

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Manager is new Ada.Finalization.Limited_Controlled with record
--        Cache        : Rules_Ref_Access;
--        Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

end Security.Policies;

Document Add_Permission

Document Add_Permission


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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
with Util.Nullables;
package Util.Serialize.IO is

   Parse_Error : exception;

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

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

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

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

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

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

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

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

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

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

   --  Write the attribute with a null value.
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String) is abstract;

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

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

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

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

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

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

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

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

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

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

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Time);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Boolean);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Integer);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Long);

   --  Write an entity with a null value.
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String) is abstract;

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

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

   type Reader is limited interface;

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

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

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

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

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

   type Parser is abstract new Util.Log.Logging with private;

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

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

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

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

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

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

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

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

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

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

end Util.Serialize.IO;

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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
with Util.Nullables;
package Util.Serialize.IO is

   Parse_Error : exception;

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

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

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

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

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

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

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

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

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

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

   --  Write the attribute with a null value.
   procedure Write_Null_Attribute (Stream : in out Output_Stream;
                                   Name   : in String) is abstract;

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

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

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

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

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

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

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

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

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

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

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Time);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Boolean);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Integer);

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_Long);

   --  Write an entity with a null value.
   procedure Write_Null_Entity (Stream : in out Output_Stream;
                                Name   : in String) is abstract;

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

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

   type Reader is limited interface;

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

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

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

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

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

   type Parser is abstract new Util.Log.Logging with private;

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

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

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

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

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

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

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

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

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

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

end Util.Serialize.IO;

Use the Input_Buffer_Stream instead of Buffered_Stream


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

package body Wiki.Parsers.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Space (C : in Wide_Wide_Character) return Boolean;
   function Is_Letter (C : in Wide_Wide_Character) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String);

   function Is_Space (C : in Wide_Wide_Character) return Boolean is
   begin
      return C = ' ' or C = LF or C = CR;
   end Is_Space;

   function Is_Letter (C : in Wide_Wide_Character) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   procedure Skip_Spaces (P : in out Parser) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Space (C) then
            Put_Back (P, C);
            return;
         end if;
      end loop;
   end Skip_Spaces;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      Name := To_Unbounded_Wide_Wide_String ("");
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Ada.Strings.Wide_Wide_Unbounded.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Quote : in Wide_Wide_Character;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = Quote;
         Append (Value, C);
      end loop;
   end Collect_Attribute_Value;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C     : Wide_Wide_Character;
      Token : Wide_Wide_Character;
   begin
      Value := To_Unbounded_Wide_Wide_String ("");
      Peek (P, Token);
      if Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wide_Wide_Character;
      Name  : Unbounded_Wide_Wide_String;
      Value : Unbounded_Wide_Wide_String;
   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Is_Space (C) and Length (Name) > 0 then
            Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      Name : Unbounded_Wide_Wide_String;
      C    : Wide_Wide_Character;
   begin
      Peek (P, C);
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      if C = '/' then
         Skip_Spaces (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
         Flush_Text (P);
         End_Element (P, Name);
      else
         Collect_Attributes (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
         Start_Element (P, Name, P.Attributes);
      end if;
   end Parse_Element;

end Wiki.Parsers.Html;

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

package body Wiki.Parsers.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Space (C : in Wide_Wide_Character) return Boolean;
   function Is_Letter (C : in Wide_Wide_Character) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String);

   function Is_Space (C : in Wide_Wide_Character) return Boolean is
   begin
      return C = ' ' or C = LF or C = CR;
   end Is_Space;

   function Is_Letter (C : in Wide_Wide_Character) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   procedure Skip_Spaces (P : in out Parser) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Space (C) then
            Put_Back (P, C);
            return;
         end if;
      end loop;
   end Skip_Spaces;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      Name := To_Unbounded_Wide_Wide_String ("");
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Ada.Strings.Wide_Wide_Unbounded.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Quote : in Wide_Wide_Character;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = Quote;
         Append (Value, C);
      end loop;
   end Collect_Attribute_Value;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C     : Wide_Wide_Character;
      Token : Wide_Wide_Character;
   begin
      Value := To_Unbounded_Wide_Wide_String ("");
      Peek (P, Token);
      if Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wide_Wide_Character;
      Name  : Unbounded_Wide_Wide_String;
      Value : Unbounded_Wide_Wide_String;
   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Is_Space (C) and Length (Name) > 0 then
            Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      Name : Unbounded_Wide_Wide_String;
      C    : Wide_Wide_Character;
   begin
      Peek (P, C);
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      if C = '/' then
         Skip_Spaces (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
         Flush_Text (P);
         End_Element (P, Name);
      else
         Collect_Attributes (P);
         Peek (P, C);
         if C = '/' then
            Peek (P, C);
            if C = '>' then
               Start_Element (P, Name, P.Attributes);
               End_Element (P, Name);
               return;
            end if;
         elsif C /= '>' then
            Put_Back (P, C);
         end if;
         Start_Element (P, Name, P.Attributes);
      end if;
   end Parse_Element;

end Wiki.Parsers.Html;

Add support for HTML close entities

Add support for HTML close entities


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

with Ada.Text_IO;
with Ada.Command_Line;
with Ada.Exceptions;

with Util.Log.Loggers;

procedure Select_User is
   Factory : ADO.Sessions.Factory.Session_Factory;
begin
   if Ada.Command_Line.Argument_Count < 1 then
      Ada.Text_IO.Put_Line ("Usage: select_user user-name ...");
      Ada.Text_IO.Put_Line ("Example: select_user joe");
      Ada.Command_Line.Set_Exit_Status (2);
      return;
   end if;

   Util.Log.Loggers.Initialize ("samples.properties");

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("samples.properties");

   --  Initialize the session factory to connect to the
   --  database defined by 'ado.database' property.
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB     : constant ADO.Sessions.Session := Factory.Get_Session;
      Stmt   : ADO.Statements.Query_Statement
        := DB.Create_Statement ("SELECT "
                                & "id, name, email, date, description, status "
                                & "FROM user WHERE name = :name");
   begin
      for I in 1 .. Ada.Command_Line.Argument_Count loop
         Stmt.Bind_Param (Name  => "name",
                          Value => Ada.Command_Line.Argument (I));
         Stmt.Execute;

         while Stmt.Has_Elements loop
            Ada.Text_IO.Put_Line ("  Id     :  " & Stmt.Get_String (0));
            Ada.Text_IO.Put_Line ("  User   :  " & Stmt.Get_String (1));
            Ada.Text_IO.Put_Line ("  Email  :  " & Stmt.Get_String (2));
            Stmt.Next;
         end loop;
      end loop;
   end;

exception
   when E : ADO.Drivers.Database_Error | ADO.Configs.Connection_Error =>
      Ada.Text_IO.Put_Line ("Cannot connect to database: "
                              & Ada.Exceptions.Exception_Message (E));
end Select_User;

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

with Ada.Text_IO;
with Ada.Command_Line;
with Ada.Exceptions;

with Util.Log.Loggers;

procedure Select_User is
   Factory : ADO.Sessions.Factory.Session_Factory;
begin
   if Ada.Command_Line.Argument_Count < 1 then
      Ada.Text_IO.Put_Line ("Usage: select_user user-name ...");
      Ada.Text_IO.Put_Line ("Example: select_user joe");
      Ada.Command_Line.Set_Exit_Status (2);
      return;
   end if;

   Util.Log.Loggers.Initialize ("samples.properties");

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("samples.properties");

   --  Initialize the session factory to connect to the
   --  database defined by 'ado.database' property.
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   declare
      DB     : constant ADO.Sessions.Session := Factory.Get_Session;
      Stmt   : ADO.Statements.Query_Statement
        := DB.Create_Statement ("SELECT "
                                & "id, name, email, date, description, status "
                                & "FROM user WHERE name = :name");
   begin
      for I in 1 .. Ada.Command_Line.Argument_Count loop
         Stmt.Bind_Param (Name  => "name",
                          Value => Ada.Command_Line.Argument (I));
         Stmt.Execute;

         while Stmt.Has_Elements loop
            Ada.Text_IO.Put_Line ("  Id     :  " & Stmt.Get_String (0));
            Ada.Text_IO.Put_Line ("  User   :  " & Stmt.Get_String (1));
            Ada.Text_IO.Put_Line ("  Email  :  " & Stmt.Get_String (2));
            Stmt.Next;
         end loop;
      end loop;
   end;

exception
   when E : ADO.Drivers.Database_Error | ADO.Sessions.Connection_Error =>
      Ada.Text_IO.Put_Line ("Cannot connect to database: "
                              & Ada.Exceptions.Exception_Message (E));
end Select_User;

Simplify the select_user example

Simplify the select_user example


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

with Ada.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Unchecked_Conversion;

with GL.Pixels.Extensions;

package body Orka.KTX is

   use Ada.Streams;

   type Unsigned_32 is mod 2 ** 32
     with Size => 32;

   type Four_Bytes_Array is array (Positive range 1 .. 4) of Stream_Element
     with Size => 32, Pack;

   function Convert_Size is new Ada.Unchecked_Conversion
     (Source => Four_Bytes_Array, Target => Unsigned_32);

   type Header_Array is array (Positive range 1 .. 13 * 4) of Stream_Element
     with Size => 32 * 13, Pack;

   type Internal_Header is record
      Endianness           : Unsigned_32;
      Data_Type            : Unsigned_32;
      Type_Size            : Unsigned_32;
      Format               : Unsigned_32;
      Internal_Format      : Unsigned_32;
      Base_Internal_Format : Unsigned_32;
      Width                : Unsigned_32;
      Height               : Unsigned_32;
      Depth                : Unsigned_32;
      Array_Elements       : Unsigned_32;
      Faces                : Unsigned_32;
      Mipmap_Levels        : Unsigned_32;
      Bytes_Key_Value_Data : Unsigned_32;
   end record
     with Size => 32 * 13, Pack;

   Identifier : constant Resources.Byte_Array
     := (16#AB#, 16#4B#, 16#54#, 16#58#, 16#20#, 16#31#,
         16#31#, 16#BB#, 16#0D#, 16#0A#, 16#1A#, 16#0A#);

   Endianness_Reference : constant := 16#04030201#;

   function Valid_Identifier (Bytes : Bytes_Reference) return Boolean is
     (Identifier = Bytes (Bytes.Value'First .. Bytes.Value'First + Identifier'Length - 1));

   function Get_Header (Bytes : Bytes_Reference) return Header is
      function Convert is new Ada.Unchecked_Conversion
        (Source => Header_Array, Target => Internal_Header);

      function Convert_To_Data_Type is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Data_Type);
      function Convert_To_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Format);
      function Convert_To_Internal_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Internal_Format);
      function Convert_To_Compressed_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Compressed_Format);

      Offset : constant Stream_Element_Offset := Bytes.Value'First + Identifier'Length;
      File_Header : constant Internal_Header := Convert (Header_Array
        (Bytes (Offset .. Offset + Header_Array'Length - 1)));

      Compressed : constant Boolean := File_Header.Data_Type = 0;
   begin
      pragma Assert (File_Header.Endianness = Endianness_Reference);
      pragma Assert (File_Header.Type_Size in 1 | 2 | 4);

      return Result : Header (Compressed) do
         pragma Assert (File_Header.Width > 0);
         if File_Header.Depth > 0 then
            pragma Assert (File_Header.Height > 0);
         end if;

         --  Set dimensions of a single texture
         Result.Width  := GL.Types.Size (File_Header.Width);
         Result.Height := GL.Types.Size (File_Header.Height);
         Result.Depth  := GL.Types.Size (File_Header.Depth);

         --  Set texture kind based on faces, array elements, and dimensions
         if File_Header.Faces = 6 then
            pragma Assert (File_Header.Width = File_Header.Height);
            pragma Assert (File_Header.Depth = 0);

            if File_Header.Array_Elements > 0 then
               Result.Kind := Texture_Cube_Map_Array;
            else
               Result.Kind := Texture_Cube_Map;
            end if;
         else
            if File_Header.Array_Elements > 0 then
               if File_Header.Depth > 0 then
                  raise Constraint_Error with "OpenGL does not support 3D texture arrays";
               elsif File_Header.Height > 0 then
                  Result.Kind := Texture_2D_Array;
               else
                  Result.Kind := Texture_1D_Array;
               end if;
            else
               if File_Header.Depth > 0 then
                  Result.Kind := Texture_3D;
               elsif File_Header.Height > 0 then
                  Result.Kind := Texture_2D;
               else
                  Result.Kind := Texture_1D;
               end if;
            end if;
         end if;

         Result.Array_Elements := GL.Types.Size (File_Header.Array_Elements);
         Result.Mipmap_Levels  := GL.Types.Size (File_Header.Mipmap_Levels);
         --  If mipmap levels is 0, then client should generate full
         --  mipmap pyramid

         Result.Bytes_Key_Value := GL.Types.Size (File_Header.Bytes_Key_Value_Data);

         if Compressed then
            pragma Assert (File_Header.Format = 0);
            pragma Assert (File_Header.Type_Size = 1);
            pragma Assert (File_Header.Mipmap_Levels > 0);

            --  Format / Internal format
            begin
               Result.Compressed_Format
                 := Convert_To_Compressed_Format (File_Header.Internal_Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid internal format (" & File_Header.Internal_Format'Image & ")";
            end;
         else
            --  Data type
            begin
               Result.Data_Type := Convert_To_Data_Type (File_Header.Data_Type);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid data type (" & File_Header.Data_Type'Image & ")";
            end;

            --  Format
            begin
               Result.Format := Convert_To_Format (File_Header.Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid format (" & File_Header.Format'Image & ")";
            end;

            --  Internal format
            begin
               Result.Internal_Format
                 := Convert_To_Internal_Format (File_Header.Internal_Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid internal format (" & File_Header.Internal_Format'Image & ")";
            end;
         end if;
      end return;
   end Get_Header;

   function Get_Key_Value_Map
     (Bytes  : Bytes_Reference;
      Length : GL.Types.Size) return KTX.String_Maps.Map
   is
      Result : KTX.String_Maps.Map;

      Non_Header_Index : constant Stream_Element_Offset
        := Bytes.Value'First + Identifier'Length + Header_Array'Length;
      Data_Index : constant Stream_Element_Offset
        := Non_Header_Index + Stream_Element_Offset (Length);
      pragma Assert (Data_Index <= Bytes.Value'Last);

      Bytes_Remaining : Natural := Natural (Length);
      Pair_Index : Stream_Element_Offset := Non_Header_Index;
   begin
      while Bytes_Remaining > 0 loop
         declare
            Size_Bytes : constant Four_Bytes_Array := Four_Bytes_Array
              (Bytes (Pair_Index .. Pair_Index + 4 - 1));

            Key_Value_Size : constant Natural := Natural (Convert_Size (Size_Bytes));
            Padding_Size   : constant Natural := 3 - ((Key_Value_Size + 3) mod 4);

            Pair_Size : constant Natural := 4 + Key_Value_Size + Padding_Size;

            type Key_Value_Array is array (Positive range 1 .. Key_Value_Size) of Stream_Element
              with Pack;
            type Character_Array is array (Positive range 1 .. Key_Value_Size) of Character
              with Pack;

            function Convert_Pair is new Ada.Unchecked_Conversion
              (Source => Key_Value_Array, Target => Character_Array);

            Key_Value_Pair : constant Key_Value_Array := Key_Value_Array (Bytes
              (Pair_Index + 4 .. Pair_Index + 4 + Stream_Element_Offset (Key_Value_Size) - 1));
            Key_Value : constant String := String (Convert_Pair (Key_Value_Pair));

            Position_NUL : constant Natural := Ada.Strings.Fixed.Index
              (Key_Value, Ada.Strings.Maps.To_Set (Ada.Characters.Latin_1.NUL));
            pragma Assert (Position_NUL > 0);
         begin
            --  Extract key and value here
            declare
               Key   : constant String := Key_Value (1 .. Position_NUL - 1);
               Value : constant String := Key_Value (Position_NUL + 1 .. Key_Value'Last);
            begin
               Result.Insert (Key, Value);
            end;

            Bytes_Remaining := Bytes_Remaining - Pair_Size;
            Pair_Index := Pair_Index + Stream_Element_Offset (Pair_Size);
         end;
      end loop;
      pragma Assert (Pair_Index = Data_Index);
      return Result;
   end Get_Key_Value_Map;

   function Get_Length
     (Bytes  : Bytes_Reference;
      Offset : Stream_Element_Offset) return Natural
   is
      Size_Bytes : constant Four_Bytes_Array := Four_Bytes_Array
        (Bytes (Offset .. Offset + 4 - 1));
   begin
      return Natural (Convert_Size (Size_Bytes));
   end Get_Length;

   function Get_Data_Offset
     (Bytes  : Bytes_Reference;
      Bytes_Key_Value : GL.Types.Size) return Stream_Element_Offset
   is (Bytes.Value'First + Identifier'Length + Header_Array'Length
        + Stream_Element_Offset (Bytes_Key_Value));

   function Create_KTX_Bytes
     (KTX_Header : Header;
      Get_Data   : not null access function (Level : GL.Objects.Textures.Mipmap_Level)
                                     return Resources.Byte_Array_Pointers.Pointer)
     return Resources.Byte_Array_Pointers.Pointer
   is
      function Convert is new Ada.Unchecked_Conversion
        (Source => Internal_Header, Target => Header_Array);
      function Convert is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => Four_Bytes_Array);

      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Data_Type,         Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Format,            Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Internal_Format,   Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Compressed_Format, Target => Unsigned_32);

      package PE renames GL.Pixels.Extensions;

      Compressed : Boolean renames KTX_Header.Compressed;

      Type_Size : constant GL.Types.Size
        := (if Compressed then 1 else PE.Bytes (KTX_Header.Data_Type));

      Faces : constant Unsigned_32
        := (if KTX_Header.Kind in Texture_Cube_Map | Texture_Cube_Map_Array then 6 else 1);

      File_Header : constant Internal_Header
        := (Endianness           => Endianness_Reference,
            Data_Type            => (if Compressed then 0 else Convert (KTX_Header.Data_Type)),
            Type_Size            => Unsigned_32 (if Compressed then 1 else Type_Size),
            Format               => (if Compressed then 0 else Convert (KTX_Header.Format)),
            Internal_Format      =>
              (if Compressed then
                 Convert (KTX_Header.Compressed_Format)
               else
                 Convert (KTX_Header.Internal_Format)),
            Base_Internal_Format =>
              (if Compressed then
                 Convert (KTX_Header.Compressed_Format)
               else
                 Convert (KTX_Header.Format)),
            Width                => Unsigned_32 (KTX_Header.Width),
            Height               => Unsigned_32 (KTX_Header.Height),
            Depth                => Unsigned_32 (if Faces = 6 then 0 else KTX_Header.Depth),
            Array_Elements       => Unsigned_32 (KTX_Header.Array_Elements),
            Faces                => Faces,
            Mipmap_Levels        => Unsigned_32 (KTX_Header.Mipmap_Levels),
            Bytes_Key_Value_Data => 0);
      --  TODO Support key value map?

      Pointer : Resources.Byte_Array_Pointers.Pointer;

      --------------------------------------------------------------------------

      Data : array (0 .. KTX_Header.Mipmap_Levels - 1) of Resources.Byte_Array_Pointers.Pointer;
      Total_Size : Stream_Element_Offset := 0;
   begin
      for Level in Data'Range loop
         Data (Level) := Get_Data (Level);
         Total_Size := Total_Size + Data (Level).Get.Value'Length;
      end loop;
      Total_Size := Total_Size + 4 * Data'Length;

      pragma Assert (if not Compressed then
                       (for all Pointer of Data => Pointer.Get.Value'Length mod 4 = 0));
      --  Data must be a multiple of 4 bytes because of the requirement
      --  of GL.Pixels.Unpack_Alignment = Words (= 4)
      --  Note: assertion is not precise because length of a row might
      --  not be a multiple of 4 bytes
      --  Note: Cube padding and mipmap padding can be assumed to be 0

      declare
         Result : constant not null Resources.Byte_Array_Access := new Resources.Byte_Array
           (1 .. Identifier'Length + Header_Array'Length + Total_Size);

         Header_Offset : constant Stream_Element_Offset := Result'First + Identifier'Length;
         Size_Offset   : Stream_Element_Offset := Header_Offset + Header_Array'Length;
      begin
         Result (Result'First .. Header_Offset - 1) := Identifier;
         Result (Header_Offset .. Size_Offset - 1)  := Stream_Element_Array (Convert (File_Header));

         for Level_Data of Data loop
            declare
               Image_Size : constant Unsigned_32
                 := (if KTX_Header.Kind = Texture_Cube_Map then
                       Level_Data.Get.Value'Length / 6
                     else
                       Level_Data.Get.Value'Length);
               Data_Offset : constant Stream_Element_Offset := Size_Offset + 4;
               Next_Offset : constant Stream_Element_Offset
                 := Data_Offset + Level_Data.Get.Value'Length;
            begin
               Result (Size_Offset .. Data_Offset - 1)
                 := Stream_Element_Array (Convert (Image_Size));
               Result (Data_Offset .. Next_Offset - 1)
                 := Level_Data.Get;

               Size_Offset := Next_Offset;
            end;
         end loop;

         Pointer.Set (Result);
         return Pointer;
      end;
   end Create_KTX_Bytes;

end Orka.KTX;

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

with Ada.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Unchecked_Conversion;

with GL.Pixels.Extensions;

package body Orka.KTX is

   use Ada.Streams;

   type Unsigned_32 is mod 2 ** 32
     with Size => 32;

   type Four_Bytes_Array is array (Positive range 1 .. 4) of Stream_Element
     with Size => 32, Pack;

   function Convert_Size is new Ada.Unchecked_Conversion
     (Source => Four_Bytes_Array, Target => Unsigned_32);

   type Header_Array is array (Positive range 1 .. 13 * 4) of Stream_Element
     with Size => 32 * 13, Pack;

   type Internal_Header is record
      Endianness           : Unsigned_32;
      Data_Type            : Unsigned_32;
      Type_Size            : Unsigned_32;
      Format               : Unsigned_32;
      Internal_Format      : Unsigned_32;
      Base_Internal_Format : Unsigned_32;
      Width                : Unsigned_32;
      Height               : Unsigned_32;
      Depth                : Unsigned_32;
      Array_Elements       : Unsigned_32;
      Faces                : Unsigned_32;
      Mipmap_Levels        : Unsigned_32;
      Bytes_Key_Value_Data : Unsigned_32;
   end record
     with Size => 32 * 13, Pack;

   Identifier : constant Resources.Byte_Array
     := (16#AB#, 16#4B#, 16#54#, 16#58#, 16#20#, 16#31#,
         16#31#, 16#BB#, 16#0D#, 16#0A#, 16#1A#, 16#0A#);

   Endianness_Reference : constant := 16#04030201#;

   function Valid_Identifier (Bytes : Bytes_Reference) return Boolean is
     (Identifier = Bytes (Bytes.Value'First .. Bytes.Value'First + Identifier'Length - 1));

   function Get_Header (Bytes : Bytes_Reference) return Header is
      function Convert is new Ada.Unchecked_Conversion
        (Source => Header_Array, Target => Internal_Header);

      function Convert_To_Data_Type is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Data_Type);
      function Convert_To_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Format);
      function Convert_To_Internal_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Internal_Format);
      function Convert_To_Compressed_Format is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => GL.Pixels.Compressed_Format);

      Offset : constant Stream_Element_Offset := Bytes.Value'First + Identifier'Length;
      File_Header : constant Internal_Header := Convert (Header_Array
        (Bytes (Offset .. Offset + Header_Array'Length - 1)));

      Compressed : constant Boolean := File_Header.Data_Type = 0;
   begin
      pragma Assert (File_Header.Endianness = Endianness_Reference);
      pragma Assert (File_Header.Type_Size in 1 | 2 | 4);

      return Result : Header (Compressed) do
         pragma Assert (File_Header.Width > 0);
         if File_Header.Depth > 0 then
            pragma Assert (File_Header.Height > 0);
         end if;

         --  Set dimensions of a single texture
         Result.Width  := GL.Types.Size (File_Header.Width);
         Result.Height := GL.Types.Size (File_Header.Height);
         Result.Depth  := GL.Types.Size (File_Header.Depth);

         --  Set texture kind based on faces, array elements, and dimensions
         if File_Header.Faces = 6 then
            pragma Assert (File_Header.Width = File_Header.Height);
            pragma Assert (File_Header.Depth = 0);

            if File_Header.Array_Elements > 0 then
               Result.Kind := Texture_Cube_Map_Array;
            else
               Result.Kind := Texture_Cube_Map;
            end if;
         else
            if File_Header.Array_Elements > 0 then
               if File_Header.Depth > 0 then
                  raise Constraint_Error with "OpenGL does not support 3D texture arrays";
               elsif File_Header.Height > 0 then
                  Result.Kind := Texture_2D_Array;
               else
                  Result.Kind := Texture_1D_Array;
               end if;
            else
               if File_Header.Depth > 0 then
                  Result.Kind := Texture_3D;
               elsif File_Header.Height > 0 then
                  Result.Kind := Texture_2D;
               else
                  Result.Kind := Texture_1D;
               end if;
            end if;
         end if;

         Result.Array_Elements := GL.Types.Size (File_Header.Array_Elements);
         Result.Mipmap_Levels  := GL.Types.Size (File_Header.Mipmap_Levels);
         --  If mipmap levels is 0, then client should generate full
         --  mipmap pyramid

         Result.Bytes_Key_Value := GL.Types.Size (File_Header.Bytes_Key_Value_Data);

         if Compressed then
            pragma Assert (File_Header.Format = 0);
            pragma Assert (File_Header.Type_Size = 1);
            pragma Assert (File_Header.Mipmap_Levels > 0);

            --  Format / Internal format
            begin
               Result.Compressed_Format
                 := Convert_To_Compressed_Format (File_Header.Internal_Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid internal format (" & File_Header.Internal_Format'Image & ")";
            end;
         else
            --  Data type
            begin
               Result.Data_Type := Convert_To_Data_Type (File_Header.Data_Type);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid data type (" & File_Header.Data_Type'Image & ")";
            end;

            --  Format
            begin
               Result.Format := Convert_To_Format (File_Header.Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid format (" & File_Header.Format'Image & ")";
            end;

            --  Internal format
            begin
               Result.Internal_Format
                 := Convert_To_Internal_Format (File_Header.Internal_Format);
            exception
               when Constraint_Error =>
                  raise Invalid_Enum_Error with
                    "invalid internal format (" & File_Header.Internal_Format'Image & ")";
            end;
         end if;
      end return;
   end Get_Header;

   function Get_Key_Value_Map
     (Bytes  : Bytes_Reference;
      Length : GL.Types.Size) return KTX.String_Maps.Map
   is
      Result : KTX.String_Maps.Map;

      Non_Header_Index : constant Stream_Element_Offset := Get_Data_Offset (Bytes, 0);
      Data_Index : constant Stream_Element_Offset
        := Non_Header_Index + Stream_Element_Offset (Length);
      pragma Assert (Data_Index <= Bytes.Value'Last);

      Bytes_Remaining : Natural := Natural (Length);
      Pair_Index : Stream_Element_Offset := Non_Header_Index;
   begin
      while Bytes_Remaining > 0 loop
         declare
            Key_Value_Size : constant Natural := Get_Length (Bytes, Pair_Index);
            Padding_Size   : constant Natural := 3 - ((Key_Value_Size + 3) mod 4);

            Pair_Size : constant Natural := 4 + Key_Value_Size + Padding_Size;
            pragma Assert (Pair_Size <= Bytes_Remaining);

            type Key_Value_Array is array (Positive range 1 .. Key_Value_Size) of Stream_Element
              with Pack;
            type Character_Array is array (Positive range 1 .. Key_Value_Size) of Character
              with Pack;

            function Convert_Pair is new Ada.Unchecked_Conversion
              (Source => Key_Value_Array, Target => Character_Array);

            Key_Value_Pair : constant Key_Value_Array := Key_Value_Array (Bytes
              (Pair_Index + 4 .. Pair_Index + 4 + Stream_Element_Offset (Key_Value_Size) - 1));
            Key_Value : constant String := String (Convert_Pair (Key_Value_Pair));

            Position_NUL : constant Natural := Ada.Strings.Fixed.Index
              (Key_Value, Ada.Strings.Maps.To_Set (Ada.Characters.Latin_1.NUL));
            pragma Assert (Position_NUL > 0);
         begin
            --  Extract key and value here
            declare
               Key   : constant String := Key_Value (1 .. Position_NUL - 1);
               Value : constant String := Key_Value (Position_NUL + 1 .. Key_Value'Last);
            begin
               Result.Insert (Key, Value);
            end;

            Bytes_Remaining := Bytes_Remaining - Pair_Size;
            Pair_Index := Pair_Index + Stream_Element_Offset (Pair_Size);
         end;
      end loop;
      pragma Assert (Pair_Index = Data_Index);
      return Result;
   end Get_Key_Value_Map;

   function Get_Length
     (Bytes  : Bytes_Reference;
      Offset : Stream_Element_Offset) return Natural
   is
      Size_Bytes : constant Four_Bytes_Array := Four_Bytes_Array
        (Bytes (Offset .. Offset + 4 - 1));
   begin
      return Natural (Convert_Size (Size_Bytes));
   end Get_Length;

   function Get_Data_Offset
     (Bytes  : Bytes_Reference;
      Bytes_Key_Value : GL.Types.Size) return Stream_Element_Offset
   is (Bytes.Value'First + Identifier'Length + Header_Array'Length
        + Stream_Element_Offset (Bytes_Key_Value));

   function Create_KTX_Bytes
     (KTX_Header : Header;
      Get_Data   : not null access function (Level : GL.Objects.Textures.Mipmap_Level)
                                     return Resources.Byte_Array_Pointers.Pointer)
     return Resources.Byte_Array_Pointers.Pointer
   is
      function Convert is new Ada.Unchecked_Conversion
        (Source => Internal_Header, Target => Header_Array);
      function Convert is new Ada.Unchecked_Conversion
        (Source => Unsigned_32, Target => Four_Bytes_Array);

      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Data_Type,         Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Format,            Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Internal_Format,   Target => Unsigned_32);
      function Convert is new Ada.Unchecked_Conversion
        (Source => GL.Pixels.Compressed_Format, Target => Unsigned_32);

      package PE renames GL.Pixels.Extensions;

      Compressed : Boolean renames KTX_Header.Compressed;

      Type_Size : constant GL.Types.Size
        := (if Compressed then 1 else PE.Bytes (KTX_Header.Data_Type));

      Faces : constant Unsigned_32
        := (if KTX_Header.Kind in Texture_Cube_Map | Texture_Cube_Map_Array then 6 else 1);

      File_Header : constant Internal_Header
        := (Endianness           => Endianness_Reference,
            Data_Type            => (if Compressed then 0 else Convert (KTX_Header.Data_Type)),
            Type_Size            => Unsigned_32 (if Compressed then 1 else Type_Size),
            Format               => (if Compressed then 0 else Convert (KTX_Header.Format)),
            Internal_Format      =>
              (if Compressed then
                 Convert (KTX_Header.Compressed_Format)
               else
                 Convert (KTX_Header.Internal_Format)),
            Base_Internal_Format =>
              (if Compressed then
                 Convert (KTX_Header.Compressed_Format)
               else
                 Convert (KTX_Header.Format)),
            Width                => Unsigned_32 (KTX_Header.Width),
            Height               => Unsigned_32 (KTX_Header.Height),
            Depth                => Unsigned_32 (if Faces = 6 then 0 else KTX_Header.Depth),
            Array_Elements       => Unsigned_32 (KTX_Header.Array_Elements),
            Faces                => Faces,
            Mipmap_Levels        => Unsigned_32 (KTX_Header.Mipmap_Levels),
            Bytes_Key_Value_Data => 0);
      --  TODO Support key value map?

      Pointer : Resources.Byte_Array_Pointers.Pointer;

      --------------------------------------------------------------------------

      Data : array (0 .. KTX_Header.Mipmap_Levels - 1) of Resources.Byte_Array_Pointers.Pointer;
      Total_Size : Stream_Element_Offset := 0;
   begin
      for Level in Data'Range loop
         Data (Level) := Get_Data (Level);
         Total_Size := Total_Size + Data (Level).Get.Value'Length;
      end loop;
      Total_Size := Total_Size + 4 * Data'Length;

      pragma Assert (if not Compressed then
                       (for all Pointer of Data => Pointer.Get.Value'Length mod 4 = 0));
      --  Data must be a multiple of 4 bytes because of the requirement
      --  of GL.Pixels.Unpack_Alignment = Words (= 4)
      --  Note: assertion is not precise because length of a row might
      --  not be a multiple of 4 bytes
      --  Note: Cube padding and mipmap padding can be assumed to be 0

      declare
         Result : constant not null Resources.Byte_Array_Access := new Resources.Byte_Array
           (1 .. Identifier'Length + Header_Array'Length + Total_Size);

         Header_Offset : constant Stream_Element_Offset := Result'First + Identifier'Length;
         Size_Offset   : Stream_Element_Offset := Header_Offset + Header_Array'Length;
      begin
         Result (Result'First .. Header_Offset - 1) := Identifier;
         Result (Header_Offset .. Size_Offset - 1)  := Stream_Element_Array (Convert (File_Header));

         for Level_Data of Data loop
            declare
               Image_Size : constant Unsigned_32
                 := (if KTX_Header.Kind = Texture_Cube_Map then
                       Level_Data.Get.Value'Length / 6
                     else
                       Level_Data.Get.Value'Length);
               Data_Offset : constant Stream_Element_Offset := Size_Offset + 4;
               Next_Offset : constant Stream_Element_Offset
                 := Data_Offset + Level_Data.Get.Value'Length;
            begin
               Result (Size_Offset .. Data_Offset - 1)
                 := Stream_Element_Array (Convert (Image_Size));
               Result (Data_Offset .. Next_Offset - 1)
                 := Level_Data.Get;

               Size_Offset := Next_Offset;
            end;
         end loop;

         Pointer.Set (Result);
         return Pointer;
      end;
   end Create_KTX_Bytes;

end Orka.KTX;

orka: Simplify function Get_Key_Value_Map in package Orka.KTX a bit

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>