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

with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Maps;
with Util.Properties.Bundles;
with Util.Locales;
with ASF.Beans;
with ASF.Requests;

--  The ASF.Locales package manages everything related to the locales.
--  It allows to register bundles that contains localized messages and be able
--  to use them in the facelet views.
package ASF.Locales is

   --  To keep the implementation simple, the maximum list of supported locales by the
   --  application is limited to 32.  Most applications support 1 or 2 languages.
   MAX_SUPPORTED_LOCALES : constant Positive := 32;

   type Bundle is new Util.Properties.Bundles.Manager
     and Util.Beans.Basic.Readonly_Bean with null record;
   type Bundle_Access is access all Bundle;

   type Factory is limited private;

   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundles.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class);

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale);

private

   type Factory is limited record
      Factory : aliased Util.Properties.Bundles.Loader;
      Bundles : Util.Strings.Maps.Map;

      --  The default locale used by the application.
      Default_Locale  : Util.Locales.Locale := Util.Locales.ENGLISH;

      --  Number of supported locales.
      Nb_Locales      : Natural := 0;

      --  The list of supported locales.
      Locales         : Util.Locales.Locale_Array (1 .. MAX_SUPPORTED_LOCALES);
   end record;

   type Factory_Access is access all Factory;

end ASF.Locales;

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

with Util.Beans.Basic;
with Util.Strings.Maps;
with Util.Properties.Bundles;
with Util.Locales;
with ASF.Beans;
with ASF.Requests;

--  The ASF.Locales package manages everything related to the locales.
--  It allows to register bundles that contains localized messages and be able
--  to use them in the facelet views.
package ASF.Locales is

   --  To keep the implementation simple, the maximum list of supported locales by the
   --  application is limited to 32.  Most applications support 1 or 2 languages.
   MAX_SUPPORTED_LOCALES : constant Positive := 32;

   type Bundle is new Util.Properties.Bundles.Manager
     and Util.Beans.Basic.Readonly_Bean with null record;
   type Bundle_Access is access all Bundle;

   type Factory is limited private;

   --  Initialize the locale support by using the configuration properties.
   --  Properties matching the pattern: bundles.var-name=bundle-name
   --  are used to register bindings linking a facelet variable var-name
   --  to the resource bundle bundle-name.
   procedure Initialize (Fac    : in out Factory;
                         Beans  : in out ASF.Beans.Bean_Factory;
                         Config : in Util.Properties.Manager'Class);

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (Fac    : in out Factory;
                       Beans  : in out ASF.Beans.Bean_Factory;
                       Name   : in String;
                       Bundle : in String);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (Fac    : in out Factory;
                          Name   : in String;
                          Locale : in String;
                          Result : out Bundle);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Fac : in Factory;
                              Req : in ASF.Requests.Request'Class)
                              return Util.Locales.Locale;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (From : in Factory)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (Into   : in out Factory;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (From : in Factory) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (Into   : in out Factory;
                                 Locale : in Util.Locales.Locale);

private

   type Factory is limited record
      Factory : aliased Util.Properties.Bundles.Loader;
      Bundles : Util.Strings.Maps.Map;

      --  The default locale used by the application.
      Default_Locale  : Util.Locales.Locale := Util.Locales.ENGLISH;

      --  Number of supported locales.
      Nb_Locales      : Natural := 0;

      --  The list of supported locales.
      Locales         : Util.Locales.Locale_Array (1 .. MAX_SUPPORTED_LOCALES);
   end record;

   type Factory_Access is access all Factory;

end ASF.Locales;

Fix compilation warning

Fix compilation warning


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

with ADO;
with ADO.Sessions;

with Util.Strings.Vectors;

with AWA.Modules;
package AWA.Tags.Modules is

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

   --  ------------------------------
   --  Module awa-tags
   --  ------------------------------
   type Tag_Module is new AWA.Modules.Module with private;
   type Tag_Module_Access is access all Tag_Module'Class;

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

   --  Get the tags module.
   function Get_Tag_Module return Tag_Module_Access;

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

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

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

   --  Find the tag identifier associated with the given tag.
   --  Return NO_IDENTIFIER if there is no such tag.
   procedure Find_Tag_Id (Session : in out ADO.Sessions.Session'Class;
                          Tag     : in String;
                          Result  : out ADO.Identifier);

private

   type Tag_Module is new AWA.Modules.Module with null record;

end AWA.Tags.Modules;

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

with ADO;
with ADO.Sessions;

with Util.Strings.Vectors;

with AWA.Modules;

--  == Integration ==
--  The <tt>Tag_Module</tt> manages the tags associated with entities.  It provides operations
--  that are used by the tag beans and the <tt>awa:tagList</tt> component to manage the tags.
--  An instance of the <tt>Tag_Module</tt> must be declared and registered in the AWA application.
--  The module instance can be defined as follows:
--
--    type Application is new AWA.Applications.Application with record
--       Tag_Module : aliased AWA.Votes.Modules.Tag_Module;
--    end record;
--
--  And registered in the `Initialize_Modules` procedure by using:
--
--    Register (App    => App.Self.all'Access,
--              Name   => AWA.Tags.Modules.NAME,
--              URI    => "tags",
--              Module => App.Tag_Module'Access);
package AWA.Tags.Modules is

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

   --  ------------------------------
   --  Module awa-tags
   --  ------------------------------
   type Tag_Module is new AWA.Modules.Module with private;
   type Tag_Module_Access is access all Tag_Module'Class;

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

   --  Get the tags module.
   function Get_Tag_Module return Tag_Module_Access;

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

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

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

   --  Find the tag identifier associated with the given tag.
   --  Return NO_IDENTIFIER if there is no such tag.
   procedure Find_Tag_Id (Session : in out ADO.Sessions.Session'Class;
                          Tag     : in String;
                          Result  : out ADO.Identifier);

private

   type Tag_Module is new AWA.Modules.Module with null record;

end AWA.Tags.Modules;

Document how to integrate the Tag_Module in the application


-----------------------------------------------------------------------
--  awa-wikis-beans -- Beans for module wikis
--  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 ADO.Utils;
with ADO.Queries;
with ADO.Sessions;
with ADO.Sessions.Entities;

with AWA.Services;
with AWA.Services.Contexts;

package body AWA.Wikis.Beans is

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wiki_Space_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Wikis.Models.Wiki_Space_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Space_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the wiki space.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Wiki_Space_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      if Bean.Is_Inserted then
         Bean.Service.Save_Wiki_Space (Bean);
      else
         Bean.Service.Create_Wiki_Space (Bean);
      end if;
   end Save;

   --  Delete the wiki space.
   procedure Delete (Bean    : in out Wiki_Space_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the Wiki_Space_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Space_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Wiki_Space_Bean_Access := new Wiki_Space_Bean;
   begin
      Object.Service   := Module;
      return Object.all'Access;
   end Create_Wiki_Space_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wiki_Page_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Wikis.Models.Wiki_Page_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Page_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      elsif Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the wiki page.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      if Bean.Is_Inserted then
         Bean.Service.Save (Bean);
      else
         Bean.Service.Create_Wiki_Page (Bean.Wiki_Space, Bean);
      end if;
   end Save;

   --  Delete the wiki page.
   overriding
   procedure Delete (Bean    : in out Wiki_Page_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the Wiki_Page_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Page_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Wiki_Page_Bean_Access := new Wiki_Page_Bean;
   begin
      Object.Service   := Module;
      return Object.all'Access;
   end Create_Wiki_Page_Bean;

   --  ------------------------------
   --  Load the list of wikis.
   --  ------------------------------
   procedure Load_Wikis (List : in Wiki_Admin_Bean) is
      use AWA.Wikis.Models;
      use AWA.Services;

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session : ADO.Sessions.Session := List.Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Wikis.Models.Query_Wiki_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "table",
                                        Table   => AWA.Wikis.Models.WIKI_SPACE_TABLE,
                                        Session => Session);
      AWA.Wikis.Models.List (List.Wiki_List_Bean.all, Session, Query);
      List.Flags (INIT_WIKI_LIST) := True;
   end Load_Wikis;

   --  ------------------------------
   --  Get the wiki space identifier.
   --  ------------------------------
   function Get_Wiki_Id (List : in Wiki_Admin_Bean) return ADO.Identifier is
      use type ADO.Identifier;
   begin
      if List.Wiki_Id = ADO.NO_IDENTIFIER then
         if not List.Flags (INIT_WIKI_LIST) then
            Load_Wikis (List);
         end if;
         if not List.Wiki_List.List.Is_Empty then
            return List.Wiki_List.List.Element (0).Id;
         end if;
      end if;
      return List.Wiki_Id;
   end Get_Wiki_Id;

   overriding
   function Get_Value (List : in Wiki_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "wikis" then
         if not List.Init_Flags (INIT_WIKI_LIST) then
            Load_Wikis (List);
         end if;
         return Util.Beans.Objects.To_Object (Value   => List.Wiki_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := List.Get_Wiki_Id;
         begin
            if Id = ADO.NO_IDENTIFIER then
               return Util.Beans.Objects.Null_Object;
            else
               return Util.Beans.Objects.To_Object (Long_Long_Integer (Id));
            end if;
         end;
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Wiki_Id := ADO.Utils.To_Identifier (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Wiki_Admin_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Admin_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Wiki_Admin_Bean_Access := new Wiki_Admin_Bean;
   begin
      Object.Module            := Module;
      Object.Flags             := Object.Init_Flags'Access;
      Object.Wiki_List_Bean    := Object.Wiki_List'Access;
      return Object.all'Access;
   end Create_Wiki_Admin_Bean;

end AWA.Wikis.Beans;

-----------------------------------------------------------------------
--  awa-wikis-beans -- Beans for module wikis
--  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 ADO.Utils;
with ADO.Queries;
with ADO.Sessions;
with ADO.Objects;
with ADO.Sessions.Entities;

with AWA.Services;
with AWA.Services.Contexts;

package body AWA.Wikis.Beans is

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wiki_Space_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Wikis.Models.Wiki_Space_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Space_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the wiki space.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Wiki_Space_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      if Bean.Is_Inserted then
         Bean.Service.Save_Wiki_Space (Bean);
      else
         Bean.Service.Create_Wiki_Space (Bean);
      end if;
   end Save;

   --  Delete the wiki space.
   procedure Delete (Bean    : in out Wiki_Space_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the Wiki_Space_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Space_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Wiki_Space_Bean_Access := new Wiki_Space_Bean;
   begin
      Object.Service   := Module;
      return Object.all'Access;
   end Create_Wiki_Space_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wiki_Page_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      elsif Name = "text" then
         if From.Content.Is_Null then
            return Util.Beans.Objects.Null_Object;
         else
            return Util.Beans.Objects.To_Object (String '(From.Content.Get_Content));
         end if;
      elsif Name = "comment" then
         if From.Content.Is_Null then
            return Util.Beans.Objects.Null_Object;
         else
            return Util.Beans.Objects.To_Object (String '(From.Content.Get_Save_Comment));
         end if;
      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      else
         return AWA.Wikis.Models.Wiki_Page_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Page_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Page (From, From.Content, From.Tags, Id);
         end;
      elsif Name = "wikiId" then
         From.Wiki_Space.Set_Id (ADO.Utils.To_Identifier (Value));
      elsif Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      elsif Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));
      elsif Name = "is_public" then
         From.Set_Is_Public (Util.Beans.Objects.To_Boolean (Value));
      elsif Name = "text" then
         From.Has_Content := True;
         From.Content.Set_Content (Util.Beans.Objects.To_String (Value));
      elsif Name = "comment" then
         From.Content.Set_Save_Comment (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the wiki page.
   --  ------------------------------
   overriding
   procedure Save (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      if Bean.Is_Inserted then
         Bean.Service.Save (Bean);
      else
         Bean.Service.Create_Wiki_Page (Bean.Wiki_Space, Bean);
      end if;
      if Bean.Has_Content then
         Bean.Service.Create_Wiki_Content (Bean, Bean.Content);
      end if;
   end Save;

   --  ------------------------------
   --  Load the wiki page.
   --  ------------------------------
   overriding
   procedure Load (Bean    : in out Wiki_Page_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Bean.Service.Load_Page (Bean, Bean.Content, Bean.Tags,
                              Bean.Wiki_Space.Get_Id, Bean.Get_Name);

   exception
      when ADO.Objects.NOT_FOUND =>
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
   end Load;

   --  Delete the wiki page.
   overriding
   procedure Delete (Bean    : in out Wiki_Page_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Delete;

   --  ------------------------------
   --  Create the Wiki_Page_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Page_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Wiki_Page_Bean_Access := new Wiki_Page_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      return Object.all'Access;
   end Create_Wiki_Page_Bean;

   --  ------------------------------
   --  Load the list of wikis.
   --  ------------------------------
   procedure Load_Wikis (List : in Wiki_Admin_Bean) is
      use AWA.Wikis.Models;
      use AWA.Services;

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session : ADO.Sessions.Session := List.Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Wikis.Models.Query_Wiki_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "table",
                                        Table   => AWA.Wikis.Models.WIKI_SPACE_TABLE,
                                        Session => Session);
      AWA.Wikis.Models.List (List.Wiki_List_Bean.all, Session, Query);
      List.Flags (INIT_WIKI_LIST) := True;
   end Load_Wikis;

   --  ------------------------------
   --  Get the wiki space identifier.
   --  ------------------------------
   function Get_Wiki_Id (List : in Wiki_Admin_Bean) return ADO.Identifier is
      use type ADO.Identifier;
   begin
      if List.Wiki_Id = ADO.NO_IDENTIFIER then
         if not List.Flags (INIT_WIKI_LIST) then
            Load_Wikis (List);
         end if;
         if not List.Wiki_List.List.Is_Empty then
            return List.Wiki_List.List.Element (0).Id;
         end if;
      end if;
      return List.Wiki_Id;
   end Get_Wiki_Id;

   overriding
   function Get_Value (List : in Wiki_Admin_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "wikis" then
         if not List.Init_Flags (INIT_WIKI_LIST) then
            Load_Wikis (List);
         end if;
         return Util.Beans.Objects.To_Object (Value   => List.Wiki_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := List.Get_Wiki_Id;
         begin
            if Id = ADO.NO_IDENTIFIER then
               return Util.Beans.Objects.Null_Object;
            else
               return Util.Beans.Objects.To_Object (Long_Long_Integer (Id));
            end if;
         end;
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wiki_Admin_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Wiki_Id := ADO.Utils.To_Identifier (Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Wiki_Admin_Bean bean instance.
   --  ------------------------------
   function Create_Wiki_Admin_Bean (Module : in AWA.Wikis.Modules.Wiki_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Wiki_Admin_Bean_Access := new Wiki_Admin_Bean;
   begin
      Object.Module            := Module;
      Object.Flags             := Object.Init_Flags'Access;
      Object.Wiki_List_Bean    := Object.Wiki_List'Access;
      return Object.all'Access;
   end Create_Wiki_Admin_Bean;

end AWA.Wikis.Beans;

Implement the Load procedure to load the wiki page Implement the Get_Value and Set_Value to get/set wiki page content


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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "2";
   synth_version_minor : constant String := "04";
   copyright_years     : constant String := "2015-2018";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

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

package Definitions is

   pragma Pure;

   synth_version_major : constant String := "2";
   synth_version_minor : constant String := "05";
   copyright_years     : constant String := "2015-2018";
   host_localbase      : constant String := "/usr/local";
   host_make           : constant String := "/usr/bin/make";
   host_pkg8           : constant String := host_localbase & "/sbin/pkg";
   host_bmake          : constant String := host_localbase & "/bin/bmake";
   host_make_program   : constant String := host_make;
   chroot_make         : constant String := "/usr/bin/make";
   chroot_bmake        : constant String := "/usr/pkg/bin/bmake -m /usr/pkg/share/mk";
   chroot_make_program : constant String := chroot_make;
   jobs_per_cpu        : constant := 2;

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type package_system is (ports_collection, pkgsrc);

   software_framework : constant package_system := ports_collection;

   --  Notes for tailoring Synth.  Use sed to:
   --  1. Modify host_localbase to value of LOCALBASE
   --  2. Change software_framework to "pkgsrc" for pkgsrc version
   --  3. Change host_make_program to "host_bmake" for Non-NetBSD pkgsrc platforms
   --  4. Change chroot_make_program to "chroot_bmake" for pkgsrc version
   --  5. On replicant.ads, change "/usr/local" to "/usr/pkg" on pkgsrc

end Definitions;

Bump version in preparation for release

Bump version in preparation for release


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

package body Gen.Model.Enums is

   --  ------------------------------
   --  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 : Value_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "value" then
         return Util.Beans.Objects.To_Object (From.Number);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  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 : Enum_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "values" then
         return From.Values_Bean;
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Type_Name);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (True);
      elsif Name = "sqlType" then
         return Util.Beans.Objects.To_Object (From.Sql_Type);
      else
         return Mappings.Mapping_Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Compare two enum literals.
   --  ------------------------------
   function "<" (Left, Right : in Value_Definition_Access) return Boolean is
   begin
      return Left.Number < Right.Number;
   end "<";

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Enum_Definition) is
   begin
      O.Target := O.Type_Name;
      O.Values.Sort;
   end Prepare;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Enum_Definition) is
   begin
      O.Values_Bean := Util.Beans.Objects.To_Object (O.Values'Unchecked_Access,
                                                     Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Add an enum value to this enum definition and return the new value.
   --  ------------------------------
   procedure Add_Value (Enum  : in out Enum_Definition;
                        Name  : in String;
                        Value : out Value_Definition_Access) is
   begin
      Value := new Value_Definition;
      Value.Name   := To_Unbounded_String (Name);
      Value.Number := Enum.Values.Get_Count;
      Enum.Values.Append (Value);
   end Add_Value;

   --  ------------------------------
   --  Create an enum with the given name.
   --  ------------------------------
   function Create_Enum (Name : in Unbounded_String) return Enum_Definition_Access is
      Enum : constant Enum_Definition_Access := new Enum_Definition;
   begin
      Enum.Name := Name;
      declare
         Pos : constant Natural := Index (Enum.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Enum.Pkg_Name := Unbounded_Slice (Enum.Name, 1, Pos - 1);
            Enum.Type_Name := Unbounded_Slice (Enum.Name, Pos + 1, Length (Enum.Name));
         else
            Enum.Pkg_Name := To_Unbounded_String ("ADO");
            Enum.Type_Name := Enum.Name;
         end if;
      end;
      return Enum;
   end Create_Enum;

end Gen.Model.Enums;

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

package body Gen.Model.Enums is

   --  ------------------------------
   --  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 : Value_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "value" then
         return Util.Beans.Objects.To_Object (From.Number);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  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 : Enum_Definition;
                       Name : String) return Util.Beans.Objects.Object is
   begin
      if Name = "values" then
         return From.Values_Bean;
      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Type_Name);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (True);
      elsif Name = "sqlType" then
         return Util.Beans.Objects.To_Object (From.Sql_Type);
      else
         return Mappings.Mapping_Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Compare two enum literals.
   --  ------------------------------
   function "<" (Left, Right : in Value_Definition_Access) return Boolean is
   begin
      return Left.Number < Right.Number;
   end "<";

   --  ------------------------------
   --  Prepare the generation of the model.
   --  ------------------------------
   overriding
   procedure Prepare (O : in out Enum_Definition) is
      procedure Sort is new Value_List.Sort_On ("<");
   begin
      O.Target := O.Type_Name;
      Sort (O.Values);
   end Prepare;

   --  ------------------------------
   --  Initialize the table definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Enum_Definition) is
   begin
      O.Values_Bean := Util.Beans.Objects.To_Object (O.Values'Unchecked_Access,
                                                     Util.Beans.Objects.STATIC);
   end Initialize;

   --  ------------------------------
   --  Add an enum value to this enum definition and return the new value.
   --  ------------------------------
   procedure Add_Value (Enum  : in out Enum_Definition;
                        Name  : in String;
                        Value : out Value_Definition_Access) is
   begin
      Value := new Value_Definition;
      Value.Name   := To_Unbounded_String (Name);
      Value.Number := Enum.Values.Get_Count;
      Enum.Values.Append (Value);
   end Add_Value;

   --  ------------------------------
   --  Create an enum with the given name.
   --  ------------------------------
   function Create_Enum (Name : in Unbounded_String) return Enum_Definition_Access is
      Enum : constant Enum_Definition_Access := new Enum_Definition;
   begin
      Enum.Name := Name;
      declare
         Pos : constant Natural := Index (Enum.Name, ".", Ada.Strings.Backward);
      begin
         if Pos > 0 then
            Enum.Pkg_Name := Unbounded_Slice (Enum.Name, 1, Pos - 1);
            Enum.Type_Name := Unbounded_Slice (Enum.Name, Pos + 1, Length (Enum.Name));
         else
            Enum.Pkg_Name := To_Unbounded_String ("ADO");
            Enum.Type_Name := Enum.Name;
         end if;
      end;
      return Enum;
   end Create_Enum;

end Gen.Model.Enums;

Fix sorting of enum values

Fix sorting of enum values


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

package body ASF.Components.Utils.Scripts is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Write the content in the Javascript queue.
   --  ------------------------------
   overriding
   procedure Write_Content (UI      : in UIScript;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI, Context);
   begin
      Writer.Queue_Script (Content);
   end Write_Content;

end ASF.Components.Utils.Scripts;

-----------------------------------------------------------------------
--  components-utils-scripts -- Javascript queue
--  Copyright (C) 2011, 2012, 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.
-----------------------------------------------------------------------

package body ASF.Components.Utils.Scripts is

   --  ------------------------------
   --  Write the content that was collected by rendering the inner children.
   --  Write the content in the Javascript queue.
   --  ------------------------------
   overriding
   procedure Write_Content (UI      : in UIScript;
                            Writer  : in out Contexts.Writer.Response_Writer'Class;
                            Content : in String;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI, Context);
   begin
      Writer.Queue_Script (Content);
   end Write_Content;

   --  ------------------------------
   --  If the component provides a src attribute, render the <script src='xxx'></script>
   --  tag with an optional async attribute.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIScript;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      declare
         Src    : constant String := UI.Get_Attribute (Context => Context, Name => "src");
         Writer : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      begin
         if Src'Length > 0 then
            Writer.Queue_Include_Script (URL   => Src,
                                         Async => UI.Get_Attribute (Context => Context,
                                                                    Name    => "async"));
         end if;
      end;
   end Encode_Begin;

end ASF.Components.Utils.Scripts;

Implement the Encode_Begin procedure to test if the <util:script> component defines a 'src' attribute and generate a <script> command to load the specified javascript source


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 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.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Vectors;
private with Util.Concurrent.Counters;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Util.Beans.Objects.Object;

   function "+" (S : String) return Unbounded_String renames To_Unbounded_String;

   function "-" (S : Unbounded_String) return String renames To_String;

   function To_String (V : in Value) return String
     renames Util.Beans.Objects.To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Unbounded_String) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Unbounded_String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Unbounded_String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Unbounded_String);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name : in String;
                                                  Item : in Value));

   --  Collect the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with the prefix are
   --  returned.
   procedure Get_Names (Self   : in Manager;
                        Into   : in out Util.Strings.Vectors.Vector;
                        Prefix : in String := "");

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager;
                        Name : in String) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Value))
      is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 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.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Strings.Vectors;
private with Util.Concurrent.Counters;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Util.Beans.Objects.Object;

   function "+" (S : String) return Unbounded_String renames To_Unbounded_String;

   function "-" (S : Unbounded_String) return String renames To_String;

   function To_String (V : in Value) return String
     renames Util.Beans.Objects.To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Unbounded_String) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return Unbounded_String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Unbounded_String) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Returns a property manager that is associated with the given name.
   --  Raises NO_PROPERTY if there is no such property manager or if a property exists
   --  but is not a property manager.
   function Get (Self : in Manager'Class;
                 Name : in String) return Manager;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Unbounded_String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Unbounded_String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Unbounded_String);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name : in String;
                                                  Item : in Value));

   --  Collect the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with the prefix are
   --  returned.
   procedure Get_Names (Self   : in Manager;
                        Into   : in out Util.Strings.Vectors.Vector;
                        Prefix : in String := "");

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager;
                        Name : in String) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Value))
      is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

   end Interface_P;

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Declare a Get function that returns a property manager


--  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 Interfaces.C.Extensions;

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

   package ICE renames Interfaces.C.Extensions;

   use Ada.Streams;

   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 => ICE.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           : ICE.Unsigned_32;
      Data_Type            : ICE.Unsigned_32;
      Type_Size            : ICE.Unsigned_32;
      Format               : ICE.Unsigned_32;
      Internal_Format      : ICE.Unsigned_32;
      Base_Internal_Format : ICE.Unsigned_32;
      Width                : ICE.Unsigned_32;
      Height               : ICE.Unsigned_32;
      Depth                : ICE.Unsigned_32;
      Array_Elements       : ICE.Unsigned_32;
      Faces                : ICE.Unsigned_32;
      Mipmap_Levels        : ICE.Unsigned_32;
      Bytes_Key_Value_Data : ICE.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
      use type ICE.Unsigned_32;

      function Convert is new Ada.Unchecked_Conversion
        (Source => Header_Array, Target => Internal_Header);

      function Convert_To_Data_Type is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Data_Type);
      function Convert_To_Format is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Format);
      function Convert_To_Internal_Format is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Internal_Format);
      function Convert_To_Compressed_Format is new Ada.Unchecked_Conversion
        (Source => ICE.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;
               Result.Depth := GL.Types.Size (File_Header.Array_Elements * File_Header.Faces);
            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;
                  Result.Depth := GL.Types.Size (File_Header.Array_Elements);
               else
                  Result.Kind := Texture_1D_Array;
                  Result.Height := GL.Types.Size (File_Header.Array_Elements);
               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;
      Data       : Bytes_Reference) return Resources.Byte_Array_Pointers.Pointer
   is
      pragma Assert (KTX_Header.Mipmap_Levels = 1);
      --  TODO Data is 1 pointer to a Byte_Array, so only supporting 1 mipmap
      --  level at the moment

      function Convert is new Ada.Unchecked_Conversion
        (Source => Internal_Header, Target => Header_Array);
      function Convert is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => Four_Bytes_Array);

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

      package PE renames GL.Pixels.Extensions;
      use type ICE.Unsigned_32;

      Compressed : Boolean renames KTX_Header.Compressed;

      pragma Assert (if not Compressed then Data.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

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

      Faces : constant ICE.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            => ICE.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                => ICE.Unsigned_32 (KTX_Header.Width),
            Height               => ICE.Unsigned_32 (KTX_Header.Height),
            Depth                => ICE.Unsigned_32 (if Faces = 6 then 0 else KTX_Header.Depth),
            Array_Elements       => ICE.Unsigned_32 (KTX_Header.Array_Elements),
            Faces                => Faces,
            Mipmap_Levels        => ICE.Unsigned_32 (KTX_Header.Mipmap_Levels),
            Bytes_Key_Value_Data => 0);
      --  TODO Support key value map?

      Pointer : Resources.Byte_Array_Pointers.Pointer;

      Result : constant not null Resources.Byte_Array_Access := new Resources.Byte_Array
        (1 .. Identifier'Length + Header_Array'Length + 4 + Data.Value'Length);
      --  TODO Supports just 1 level at the moment

      Image_Size : constant ICE.Unsigned_32
        := (if KTX_Header.Kind = Texture_Cube_Map then
              Data.Value'Length / 6
            else
              Data.Value'Length);

      Header_Offset : constant Stream_Element_Offset := Result'First + Identifier'Length;
      Size_Offset   : constant Stream_Element_Offset := Header_Offset + Header_Array'Length;
      Data_Offset   : constant Stream_Element_Offset := Size_Offset + 4;
   begin
      Result (Result'First .. Header_Offset - 1) := Identifier;
      Result (Header_Offset .. Size_Offset - 1)  := Stream_Element_Array (Convert (File_Header));
      Result (Size_Offset .. Data_Offset - 1)    := Stream_Element_Array (Convert (Image_Size));
      Result (Data_Offset .. Result'Last)        := Data;
      Pointer.Set (Result);
      return Pointer;
   end Create_KTX_Bytes;

end Orka.KTX;

--  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 Interfaces.C.Extensions;

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

   package ICE renames Interfaces.C.Extensions;

   use Ada.Streams;

   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 => ICE.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           : ICE.Unsigned_32;
      Data_Type            : ICE.Unsigned_32;
      Type_Size            : ICE.Unsigned_32;
      Format               : ICE.Unsigned_32;
      Internal_Format      : ICE.Unsigned_32;
      Base_Internal_Format : ICE.Unsigned_32;
      Width                : ICE.Unsigned_32;
      Height               : ICE.Unsigned_32;
      Depth                : ICE.Unsigned_32;
      Array_Elements       : ICE.Unsigned_32;
      Faces                : ICE.Unsigned_32;
      Mipmap_Levels        : ICE.Unsigned_32;
      Bytes_Key_Value_Data : ICE.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
      use type ICE.Unsigned_32;

      function Convert is new Ada.Unchecked_Conversion
        (Source => Header_Array, Target => Internal_Header);

      function Convert_To_Data_Type is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Data_Type);
      function Convert_To_Format is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Format);
      function Convert_To_Internal_Format is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => GL.Pixels.Internal_Format);
      function Convert_To_Compressed_Format is new Ada.Unchecked_Conversion
        (Source => ICE.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;
      Data       : Bytes_Reference) return Resources.Byte_Array_Pointers.Pointer
   is
      pragma Assert (KTX_Header.Mipmap_Levels = 1);
      --  TODO Data is 1 pointer to a Byte_Array, so only supporting 1 mipmap
      --  level at the moment

      function Convert is new Ada.Unchecked_Conversion
        (Source => Internal_Header, Target => Header_Array);
      function Convert is new Ada.Unchecked_Conversion
        (Source => ICE.Unsigned_32, Target => Four_Bytes_Array);

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

      package PE renames GL.Pixels.Extensions;
      use type ICE.Unsigned_32;

      Compressed : Boolean renames KTX_Header.Compressed;

      pragma Assert (if not Compressed then Data.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

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

      Faces : constant ICE.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            => ICE.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                => ICE.Unsigned_32 (KTX_Header.Width),
            Height               => ICE.Unsigned_32 (KTX_Header.Height),
            Depth                => ICE.Unsigned_32 (if Faces = 6 then 0 else KTX_Header.Depth),
            Array_Elements       => ICE.Unsigned_32 (KTX_Header.Array_Elements),
            Faces                => Faces,
            Mipmap_Levels        => ICE.Unsigned_32 (KTX_Header.Mipmap_Levels),
            Bytes_Key_Value_Data => 0);
      --  TODO Support key value map?

      Pointer : Resources.Byte_Array_Pointers.Pointer;

      Result : constant not null Resources.Byte_Array_Access := new Resources.Byte_Array
        (1 .. Identifier'Length + Header_Array'Length + 4 + Data.Value'Length);
      --  TODO Supports just 1 level at the moment

      Image_Size : constant ICE.Unsigned_32
        := (if KTX_Header.Kind = Texture_Cube_Map then
              Data.Value'Length / 6
            else
              Data.Value'Length);

      Header_Offset : constant Stream_Element_Offset := Result'First + Identifier'Length;
      Size_Offset   : constant Stream_Element_Offset := Header_Offset + Header_Array'Length;
      Data_Offset   : constant Stream_Element_Offset := Size_Offset + 4;
   begin
      Result (Result'First .. Header_Offset - 1) := Identifier;
      Result (Header_Offset .. Size_Offset - 1)  := Stream_Element_Array (Convert (File_Header));
      Result (Size_Offset .. Data_Offset - 1)    := Stream_Element_Array (Convert (Image_Size));
      Result (Data_Offset .. Result'Last)        := Data;
      Pointer.Set (Result);
      return Pointer;
   end Create_KTX_Bytes;

end Orka.KTX;

orka: Fix incorrectly overriding component Depth of KTX header

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