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

with Security.Permissions;

with AWA.Modules;
with AWA.Questions.Models;
package AWA.Questions.Services is

   --  Define the permissions.
   package ACL_Create_Questions is new Security.Permissions.Definition ("question-create");
   package ACL_Delete_Questions is new Security.Permissions.Definition ("question-delete");
   package ACL_Update_Questions is new Security.Permissions.Definition ("question-update");
   package ACL_Answer_Questions is new Security.Permissions.Definition ("answer-create");

   --  The maximum length for a short description.
   SHORT_DESCRIPTION_LENGTH : constant Positive := 200;

   --  ------------------------------
   --  Service services
   --  ------------------------------
   type Question_Service is new AWA.Modules.Module_Manager with private;
   type Question_Service_Access is access all Question_Service'Class;

   --  Create or save the question.
   procedure Save_Question (Model    : in Question_Service;
                            Question : in out AWA.Questions.Models.Question_Ref'Class);

   --  Delete the question.
   procedure Delete_Question (Model    : in Question_Service;
                              Question : in out AWA.Questions.Models.Question_Ref'Class);

   --  Load the question.
   procedure Load_Question (Model    : in Question_Service;
                            Question : in out AWA.Questions.Models.Question_Ref'Class;
                            Id       : in ADO.Identifier);

   --  Create or save the answer.
   procedure Save_Answer (Model    : in Question_Service;
                          Question : in AWA.Questions.Models.Question_Ref'Class;
                          Answer   : in out AWA.Questions.Models.Answer_Ref'Class);

   --  Load the answer.
   procedure Load_Answer (Model  : in Question_Service;
                          Answer : in out AWA.Questions.Models.Answer_Ref'Class;
                          Id     : in ADO.Identifier);

private

   type Question_Service is new AWA.Modules.Module_Manager with null record;

end AWA.Questions.Services;

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

with Security.Permissions;

with AWA.Modules;
with AWA.Questions.Models;
package AWA.Questions.Services is

   --  Define the permissions.
   package ACL_Create_Questions is new Security.Permissions.Definition ("question-create");
   package ACL_Delete_Questions is new Security.Permissions.Definition ("question-delete");
   package ACL_Update_Questions is new Security.Permissions.Definition ("question-update");
   package ACL_Answer_Questions is new Security.Permissions.Definition ("answer-create");

   --  The maximum length for a short description.
   SHORT_DESCRIPTION_LENGTH : constant Positive := 200;

   --  ------------------------------
   --  Service services
   --  ------------------------------
   type Question_Service is new AWA.Modules.Module_Manager with private;
   type Question_Service_Access is access all Question_Service'Class;

   --  Create or save the question.
   procedure Save_Question (Model    : in Question_Service;
                            Question : in out AWA.Questions.Models.Question_Ref'Class);

   --  Delete the question.
   procedure Delete_Question (Model    : in Question_Service;
                              Question : in out AWA.Questions.Models.Question_Ref'Class);

   --  Load the question.
   procedure Load_Question (Model    : in Question_Service;
                            Question : in out AWA.Questions.Models.Question_Ref'Class;
                            Id       : in ADO.Identifier);

   --  Create or save the answer.
   procedure Save_Answer (Model    : in Question_Service;
                          Question : in AWA.Questions.Models.Question_Ref'Class;
                          Answer   : in out AWA.Questions.Models.Answer_Ref'Class);

   --  Load the answer.
   procedure Load_Answer (Model    : in Question_Service;
                          Answer   : in out AWA.Questions.Models.Answer_Ref'Class;
                          Question : in out AWA.Questions.Models.Question_Ref'Class;
                          Id       : in ADO.Identifier);

private

   type Question_Service is new AWA.Modules.Module_Manager with null record;

end AWA.Questions.Services;

Load the question associated with the answer


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

package Gen.Commands.Layout is

   --  ------------------------------
   --  Layout Creation Command
   --  ------------------------------
   --  This command adds a XHTML layout to the web application.
   type Command is new Gen.Commands.Command with null record;

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

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

end Gen.Commands.Layout;

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

package Gen.Commands.Layout is

   --  ------------------------------
   --  Layout Creation Command
   --  ------------------------------
   --  This command adds a XHTML layout to the web application.
   type Command is new Gen.Commands.Command with null record;

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

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

end Gen.Commands.Layout;

Add Name parameter to the Help procedure


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Streams;
with Ada.Strings.Hash;

with GL.Low_Level.Enums;
with GL.Objects.Textures;
with GL.Pixels;
with GL.Types;

with Orka.Resources;

private package Orka.KTX is
   pragma Preelaborate;

   package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => String,
      Element_Type    => String,
      Hash            => Ada.Strings.Hash,
      Equivalent_Keys => "=");

   use GL.Low_Level.Enums;
   use type GL.Types.Size;

   type Header (Compressed : Boolean) is record
      Kind   : GL.Low_Level.Enums.Texture_Kind;
      Width  : GL.Types.Size;
      Height : GL.Types.Size;
      Depth  : GL.Types.Size;
      Array_Elements : GL.Types.Size;
      Mipmap_Levels  : GL.Objects.Textures.Mipmap_Level;
      Bytes_Key_Value : GL.Types.Size;
      case Compressed is
         when True =>
            Compressed_Format : GL.Pixels.Compressed_Format;
         when False =>
            Data_Type       : GL.Pixels.Data_Type;
            Format          : GL.Pixels.Format;
            Internal_Format : GL.Pixels.Internal_Format;
      end case;
   end record
     with Dynamic_Predicate => Header.Width > 0
       and (if Header.Depth > 0  then Header.Height > 0)
       and (if Header.Height = 0 then Header.Depth = 0)
       and (if Header.Compressed then Header.Mipmap_Levels > 0)
       and (case Header.Kind is
              when Texture_1D | Texture_2D | Texture_3D => Header.Array_Elements = 0,
              when Texture_Cube_Map                     => Header.Array_Elements = 0,
              when others                               => Header.Array_Elements > 0)
       and (case Header.Kind is
              when Texture_1D | Texture_1D_Array => Header.Height = 0,
              when Texture_2D | Texture_2D_Array => Header.Height > 0 and Header.Depth = 0,
              when Texture_3D                    => Header.Depth > 0,
              when Texture_Cube_Map       => Header.Width = Header.Height and Header.Depth = 0,
              when Texture_Cube_Map_Array => Header.Width = Header.Height and Header.Depth = 0,
              when others => raise Constraint_Error);

   subtype Bytes_Reference is Resources.Byte_Array_Pointers.Constant_Reference;

   function Valid_Identifier (Bytes : Bytes_Reference) return Boolean;

   function Get_Header (Bytes : Bytes_Reference) return Header;

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

   function Get_Length
     (Bytes  : Bytes_Reference;
      Offset : Ada.Streams.Stream_Element_Offset) return Natural;

   function Get_Data_Offset
     (Bytes  : Bytes_Reference;
      Bytes_Key_Value : GL.Types.Size) return Ada.Streams.Stream_Element_Offset;

   Invalid_Enum_Error : exception;

   function Create_KTX_Bytes
     (KTX_Header : Header;
      Data       : Bytes_Reference) return Resources.Byte_Array_Pointers.Pointer;

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 Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Streams;
with Ada.Strings.Hash;

with GL.Low_Level.Enums;
with GL.Objects.Textures;
with GL.Pixels;
with GL.Types;

with Orka.Resources;

private package Orka.KTX is
   pragma Preelaborate;

   package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => String,
      Element_Type    => String,
      Hash            => Ada.Strings.Hash,
      Equivalent_Keys => "=");

   use GL.Low_Level.Enums;
   use type GL.Types.Size;

   type Header (Compressed : Boolean) is record
      Kind   : GL.Low_Level.Enums.Texture_Kind;
      Width  : GL.Types.Size;
      Height : GL.Types.Size;
      Depth  : GL.Types.Size;
      Array_Elements : GL.Types.Size;
      Mipmap_Levels  : GL.Objects.Textures.Mipmap_Level;
      Bytes_Key_Value : GL.Types.Size;
      case Compressed is
         when True =>
            Compressed_Format : GL.Pixels.Compressed_Format;
         when False =>
            Data_Type       : GL.Pixels.Data_Type;
            Format          : GL.Pixels.Format;
            Internal_Format : GL.Pixels.Internal_Format;
      end case;
   end record
     with Dynamic_Predicate => Header.Width > 0
       and not (Header.Height = 0 and Header.Depth > 0)
       and (if Header.Compressed then Header.Mipmap_Levels > 0)
       and (case Header.Kind is
              when Texture_1D | Texture_2D | Texture_3D => Header.Array_Elements = 0,
              when Texture_Cube_Map                     => Header.Array_Elements = 0,
              when others                               => Header.Array_Elements > 0)
       and (case Header.Kind is
              when Texture_1D | Texture_1D_Array => Header.Height = 0,
              when Texture_2D | Texture_2D_Array => Header.Height > 0 and Header.Depth = 0,
              when Texture_3D                    => Header.Depth > 0,
              when Texture_Cube_Map       => Header.Width = Header.Height and Header.Depth = 0,
              when Texture_Cube_Map_Array => Header.Width = Header.Height and Header.Depth = 0,
              when others => raise Constraint_Error);

   subtype Bytes_Reference is Resources.Byte_Array_Pointers.Constant_Reference;

   function Valid_Identifier (Bytes : Bytes_Reference) return Boolean;

   function Get_Header (Bytes : Bytes_Reference) return Header;

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

   function Get_Length
     (Bytes  : Bytes_Reference;
      Offset : Ada.Streams.Stream_Element_Offset) return Natural;

   function Get_Data_Offset
     (Bytes  : Bytes_Reference;
      Bytes_Key_Value : GL.Types.Size) return Ada.Streams.Stream_Element_Offset;

   Invalid_Enum_Error : exception;

   function Create_KTX_Bytes
     (KTX_Header : Header;
      Data       : Bytes_Reference) return Resources.Byte_Array_Pointers.Pointer;

end Orka.KTX;

orka: Simplify Dynamic_Predicate of KTX header a bit

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


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

with Util.Encoders.Base16;
with Util.Encoders.Base64;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package body Util.Encoders.HMAC.SHA1 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
      use type Ada.Streams.Stream_Element_Offset;
      use type Ada.Streams.Stream_Element;
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA1.Update (E.SHA, Key);
         Util.Encoders.SHA1.Finish (E.SHA, E.Key (0 .. 19));
         E.Key_Len := 19;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array) is
      use type Ada.Streams.Stream_Element;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      Util.Encoders.SHA1.Finish (E.SHA, Hash);

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA1.Update (E.SHA, Hash);
      Util.Encoders.SHA1.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Hash'Length);
      for Buf'Address use Hash'Address;
      pragma Import (Ada, Buf);

      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      Finish (E, H);
      B.Transform (Data => H, Into => Buf, Last => Last, Encoded => Encoded);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Hash'Length);
      for Buf'Address use Hash'Address;
      pragma Import (Ada, Buf);

      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Transform (Data => H, Into => Buf, Last => Last, Encoded => Encoded);
   end Finish_Base64;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
   begin
      null;
   end Transform;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA1;

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

with Util.Encoders.Base16;
with Util.Encoders.Base64;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package body Util.Encoders.HMAC.SHA1 is

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Hash_Array;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   --  ------------------------------
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish (Ctx, Result);
      return Result;
   end Sign;

   --  ------------------------------
   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest is
      Ctx    : Context;
      Result : Util.Encoders.SHA1.Base64_Digest;
   begin
      Set_Key (Ctx, Key);
      Update (Ctx, Data);
      Finish_Base64 (Ctx, Result, URL);
      return Result;
   end Sign_Base64;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in String) is
      Buf : Ada.Streams.Stream_Element_Array (1 .. Key'Length);
      for Buf'Address use Key'Address;
      pragma Import (Ada, Buf);

   begin
      Set_Key (E, Buf);
   end Set_Key;

   IPAD : constant Ada.Streams.Stream_Element := 16#36#;
   OPAD : constant Ada.Streams.Stream_Element := 16#5c#;

   --  ------------------------------
   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   --  ------------------------------
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array) is
      use type Ada.Streams.Stream_Element_Offset;
      use type Ada.Streams.Stream_Element;
   begin
      --  Reduce the key
      if Key'Length > 64 then
         Util.Encoders.SHA1.Update (E.SHA, Key);
         Util.Encoders.SHA1.Finish (E.SHA, E.Key (0 .. 19));
         E.Key_Len := 19;
      else
         E.Key_Len := Key'Length - 1;
         E.Key (0 .. E.Key_Len) := Key;
      end if;

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := IPAD xor E.Key (I);
         end loop;
         for I in E.Key_Len + 1 .. 63 loop
            Block (I) := IPAD;
         end loop;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
   end Set_Key;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in String) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Update the hash with the string.
   --  ------------------------------
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array) is
   begin
      Util.Encoders.SHA1.Update (E.SHA, S);
   end Update;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array) is
      use type Ada.Streams.Stream_Element;
      use type Ada.Streams.Stream_Element_Offset;
   begin
      Util.Encoders.SHA1.Finish (E.SHA, Hash);

      --  Hash the key in the SHA1 context.
      declare
         Block : Ada.Streams.Stream_Element_Array (0 .. 63);
      begin
         for I in 0 .. E.Key_Len loop
            Block (I) := OPAD xor E.Key (I);
         end loop;
         if E.Key_Len < 63 then
            for I in E.Key_Len + 1 .. 63 loop
               Block (I) := OPAD;
            end loop;
         end if;
         Util.Encoders.SHA1.Update (E.SHA, Block);
      end;
      Util.Encoders.SHA1.Update (E.SHA, Hash);
      Util.Encoders.SHA1.Finish (E.SHA, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   --  ------------------------------
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base16.Encoder;
   begin
      Finish (E, H);
      B.Convert (H, Hash);
   end Finish;

   --  ------------------------------
   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   --  ------------------------------
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False) is
      H       : Util.Encoders.SHA1.Hash_Array;
      B       : Util.Encoders.Base64.Encoder;
   begin
      Finish (E, H);
      B.Set_URL_Mode (URL);
      B.Convert (H, Hash);
   end Finish_Base64;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is
   begin
      null;
   end Transform;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context) is
   begin
      null;
   end Initialize;

end Util.Encoders.HMAC.SHA1;

Refactor the encoders to use the Convert procedure to simplify the final HMAC-SHA1 conversion


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

--  The ASF.Validators.Texts defines various text oriented validators.
package body ASF.Validators.Texts is

   --  ------------------------------
   --  Length_Validator
   --  ------------------------------

   --  ------------------------------
   --  Create a length validator.
   --  ------------------------------
   function Create_Length_Validator (Minimum : in Natural;
                                     Maximum : in Natural) return Validator_Access is
      Result : constant Length_Validator_Access := new Length_Validator;
   begin
      Result.Minimum := Minimum;
      Result.Maximum := Maximum;
      return Result.all'Access;
   end Create_Length_Validator;

   --  ------------------------------
   --  Verify that the value's length is between the validator minimum and maximum
   --  boundaries.
   --  If some error are found, the procedure should create a FacesMessage
   --  describing the problem and add that message to the current faces context.
   --  The procedure can examine the state and modify the component tree.
   --  It must raise the Invalid_Value exception if the value is not valid.
   --  ------------------------------
   procedure Validate (Valid     : in Length_Validator;
                       Context   : in out ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in out ASF.Components.Base.UIComponent'Class;
                       Value     : in EL.Objects.Object) is
   begin
      if EL.Objects.Is_Null (Value) then
         return;
      end if;

      declare
         S : constant String := EL.Objects.To_String (Value);
      begin
         if S'Length > Valid.Maximum then
            Component.Add_Message (Name    => "validatorMessage",
                                   Default => MAXIMUM_MESSAGE_ID,
                                   Context => Context);
            raise Invalid_Value;
         end if;
         if S'Length < Valid.Minimum then
            Component.Add_Message (Name    => "validatorMessage",
                                   Default => MINIMUM_MESSAGE_ID,
                                   Context => Context);
            raise Invalid_Value;
         end if;
      end;
   end Validate;

end ASF.Validators.Texts;

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

with Util.Beans.Objects;

--  The ASF.Validators.Texts defines various text oriented validators.
package body ASF.Validators.Texts is

   --  ------------------------------
   --  Length_Validator
   --  ------------------------------

   --  ------------------------------
   --  Create a length validator.
   --  ------------------------------
   function Create_Length_Validator (Minimum : in Natural;
                                     Maximum : in Natural) return Validator_Access is
      Result : constant Length_Validator_Access := new Length_Validator;
   begin
      Result.Minimum := Minimum;
      Result.Maximum := Maximum;
      return Result.all'Access;
   end Create_Length_Validator;

   --  ------------------------------
   --  Verify that the value's length is between the validator minimum and maximum
   --  boundaries.
   --  If some error are found, the procedure should create a FacesMessage
   --  describing the problem and add that message to the current faces context.
   --  The procedure can examine the state and modify the component tree.
   --  It must raise the Invalid_Value exception if the value is not valid.
   --  ------------------------------
   procedure Validate (Valid     : in Length_Validator;
                       Context   : in out ASF.Contexts.Faces.Faces_Context'Class;
                       Component : in out ASF.Components.Base.UIComponent'Class;
                       Value     : in EL.Objects.Object) is
   begin
      if EL.Objects.Is_Null (Value) then
         return;
      end if;

      declare
         S : constant String := EL.Objects.To_String (Value);
      begin
         if S'Length > Valid.Maximum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MAXIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Maximum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
         if S'Length < Valid.Minimum then
            Component.Add_Message (Name    => ASF.Components.VALIDATOR_MESSAGE_NAME,
                                   Default => MINIMUM_MESSAGE_ID,
                                   Arg1    => Util.Beans.Objects.To_Object (Valid.Minimum),
                                   Arg2    => Component.Get_Label (Context),
                                   Context => Context);
            raise Invalid_Value;
         end if;
      end;
   end Validate;

end ASF.Validators.Texts;

Add a message when the validation fails

Add a message when the validation fails


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

package Gen.Commands.Plugins is

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   type Command is new Gen.Commands.Command with null record;

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

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

end Gen.Commands.Plugins;

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

package Gen.Commands.Plugins is

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   type Command is new Gen.Commands.Command with null record;

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

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

end Gen.Commands.Plugins;


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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

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

with Ada.Unchecked_Deallocation;
package body Util.Concurrent.Fifos is

   --  ------------------------------
   --  Put the element in the queue.
   --  ------------------------------
   procedure Enqueue (Into    : in out Fifo;
                      Item    : in Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         Into.Buffer.Enqueue (Item);
      else
         select
            Into.Buffer.Enqueue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Enqueue;

   --  ------------------------------
   --  Get an element from the queue.
   --  Wait until one element gets available.
   --  ------------------------------
   procedure Dequeue (From    : in out Fifo;
                      Item    : out Element_Type;
                      Wait    : in Duration := FOREVER) is
   begin
      if Wait < 0.0 then
         From.Buffer.Dequeue (Item);
      else
         select
            From.Buffer.Dequeue (Item);
         or
            delay Wait;
            raise Timeout;
         end select;
      end if;
   end Dequeue;

   --  ------------------------------
   --  Get the number of elements in the queue.
   --  ------------------------------
   function Get_Count (From : in Fifo) return Natural is
   begin
      return From.Buffer.Get_Count;
   end Get_Count;

   --  ------------------------------
   --  Set the queue size.
   --  ------------------------------
   procedure Set_Size (Into : in out Fifo;
                       Capacity : in Positive) is
   begin
      Into.Buffer.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Initializes the queue.
   --  ------------------------------
   overriding
   procedure Initialize (Object : in out Fifo) is
   begin
      Object.Buffer.Set_Size (Default_Size);
   end Initialize;

   --  ------------------------------
   --  Release the queue elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Fifo) is
   begin
      if Clear_On_Dequeue then
         while Object.Get_Count > 0 loop
            declare
               Unused : Element_Type;
            begin
               Object.Dequeue (Unused);
            end;
         end loop;
      end if;
      Object.Buffer.Set_Size (0);
   end Finalize;

   --  Queue of objects.
   protected body Protected_Fifo is

      --  ------------------------------
      --  Put the element in the queue.
      --  If the queue is full, wait until some room is available.
      --  ------------------------------
      entry Enqueue (Item : in Element_Type) when Count < Elements'Length is
      begin
         Elements (Last) := Item;
         Last := Last + 1;
         if Last > Elements'Last then
            if Clear_On_Dequeue then
               Last := Elements'First + 1;
            else
               Last := Elements'First;
            end if;
         end if;
         Count := Count + 1;
      end Enqueue;

      --  ------------------------------
      --  Get an element from the queue.
      --  Wait until one element gets available.
      --  ------------------------------
      entry Dequeue (Item : out Element_Type) when Count > 0 is
      begin
         Count := Count - 1;
         Item := Elements (First);

         --  For the clear on dequeue mode, erase the queue element.
         --  If the element holds some storage or a reference, this gets cleared here.
         --  The element used to clear is at index 0 (which does not exist if Clear_On_Dequeue
         --  is false).  There is no overhead when this is not used
         --  (ie, instantiation/compile time flag).
         if Clear_On_Dequeue then
            Elements (First) := Elements (0);
         end if;
         First := First + 1;
         if First > Elements'Last then
            if Clear_On_Dequeue then
               First := Elements'First + 1;
            else
               First := Elements'First;
            end if;
         end if;
      end Dequeue;

      --  ------------------------------
      --  Get the number of elements in the queue.
      --  ------------------------------
      function Get_Count return Natural is
      begin
         return Count;
      end Get_Count;

      --  ------------------------------
      --  Set the queue size.
      --  ------------------------------
      procedure Set_Size (Capacity : in Natural) is
         procedure Free is new Ada.Unchecked_Deallocation (Element_Array, Element_Array_Access);
         First_Pos : Natural := 1;
      begin
         if Clear_On_Dequeue then
            First_Pos := 0;
         end if;
         if Capacity = 0 then
            Free (Elements);
         elsif Elements = null then
            Elements := new Element_Array (First_Pos .. Capacity);
         else
            declare
               New_Array : constant Element_Array_Access := new Element_Array (First_Pos .. Capacity);
            begin
               if Capacity > Elements'Length then
                  New_Array (First_Pos .. Elements'Last) := Elements (First_Pos .. Elements'Last);
               else
                  New_Array (First_Pos .. Capacity) := Elements (First_Pos .. Capacity);
               end if;

               Free (Elements);
               Elements := New_Array;
            end;
         end if;
      end Set_Size;

   end Protected_Fifo;

end Util.Concurrent.Fifos;

Fix compilation warning reported by gcc 4.7


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

--  The 'ELNode' describes an expression that can later be evaluated
--  on an expression context.  Expressions are parsed and translated
--  to a read-only tree.

with EL.Functions;
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Strings.Unbounded;
with Util.Concurrent.Counters;
private package EL.Expressions.Nodes is

   use EL.Functions;
   use Ada.Strings.Wide_Wide_Unbounded;
   use Ada.Strings.Unbounded;

   type Reduction;

   type ELNode is abstract tagged record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

   type ELNode_Access is access all ELNode'Class;

   type Reduction is record
      Node  : ELNode_Access;
      Value : EL.Objects.Object;
   end record;

   --  Evaluate a node on a given context.
   function Get_Value (Expr    : ELNode;
                       Context : ELContext'Class) return Object is abstract;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   function Reduce (Expr    : ELNode;
                    Context : ELContext'Class) return Reduction is abstract;

   --  Delete the expression tree (calls Delete (ELNode_Access) recursively).
   procedure Delete (Node : in out ELNode) is abstract;

   --  Delete the expression tree.  Free the memory allocated by nodes
   --  of the expression tree.  Clears the node pointer.
   procedure Delete (Node : in out ELNode_Access);

   --  ------------------------------
   --  Unary expression node
   --  ------------------------------
   type ELUnary is new ELNode with private;

   type Unary_Node is (EL_VOID, EL_NOT, EL_MINUS);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELUnary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELUnary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELUnary);

   --  ------------------------------
   --  Binary expression node
   --  ------------------------------
   type ELBinary is new ELNode with private;
   type Binary_Node is (EL_EQ, EL_NE, EL_LE, EL_LT, EL_GE, EL_GT,
                        EL_ADD, EL_SUB, EL_MUL, EL_DIV, EL_MOD,
                        EL_AND, EL_OR, EL_LAND, EL_LOR, EL_CONCAT);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELBinary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELBinary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELBinary);

   --  ------------------------------
   --  Ternary expression node
   --  ------------------------------
   type ELTernary is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELTernary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELTernary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELTernary);

   --  ------------------------------
   --  Variable to be looked at in the expression context
   --  ------------------------------
   type ELVariable is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELVariable;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELVariable;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELVariable);

   --  ------------------------------
   --  Value property referring to a variable
   --  ------------------------------
   type ELValue is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELValue;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELValue;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELValue);

   --  ------------------------------
   --  Literal object (integer, boolean, float, string)
   --  ------------------------------
   type ELObject is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELObject;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELObject;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELObject);

   --  ------------------------------
   --  Function call with up to 4 arguments
   --  ------------------------------
   type ELFunction is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELFunction;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELFunction;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELFunction);

   --  Create constant nodes
   function Create_Node (Value   : Boolean) return ELNode_Access;
   function Create_Node (Value   : Long_Long_Integer) return ELNode_Access;
   function Create_Node (Value   : String) return ELNode_Access;
   function Create_Node (Value   : Wide_Wide_String) return ELNode_Access;
   function Create_Node (Value   : Long_Float) return ELNode_Access;
   function Create_Node (Value : Unbounded_Wide_Wide_String) return ELNode_Access;
   function Create_Variable (Name : Unbounded_String) return ELNode_Access;
   function Create_Value (Variable : ELNode_Access;
                          Name     : Unbounded_String) return ELNode_Access;

   --  Create unary expressions
   function Create_Node (Of_Type : Unary_Node;
                         Expr    : ELNode_Access) return ELNode_Access;

   --  Create binary expressions
   function Create_Node (Of_Type : Binary_Node;
                         Left    : ELNode_Access;
                         Right   : ELNode_Access) return ELNode_Access;

   --  Create a ternary expression.
   function Create_Node (Cond  : ELNode_Access;
                         Left  : ELNode_Access;
                         Right : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access;
                         Arg4  : ELNode_Access) return ELNode_Access;

private

   type ELUnary is new ELNode with record
      Kind : Unary_Node;
      Node : ELNode_Access;
   end record;

   --  ------------------------------
   --  Binary nodes
   --  ------------------------------

   type ELBinary is new ELNode with record
      Kind  : Binary_Node;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  ------------------------------
   --  Ternary expression
   --  ------------------------------
   type ELTernary is new ELNode with record
      Cond  : ELNode_Access;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  #{bean.name}   - Bean name, Bean property
   --  #{bean[12]}    - Bean name,

   --  Variable to be looked at in the expression context
   type ELVariable is new ELNode with record
      Name     : Unbounded_String;
   end record;

   type ELValue is new ELNode with record
      Name     : Unbounded_String;
      Variable : ELNode_Access;
   end record;

   --  A literal object (integer, boolean, float, String)
   type ELObject is new ELNode with record
      Value : Object;
   end record;

   --  A function call with up to 4 arguments.
   type ELFunction is new ELNode with record
      Func : EL.Functions.Function_Access;
      Arg1 : ELNode_Access;
      Arg2 : ELNode_Access;
      Arg3 : ELNode_Access;
      Arg4 : ELNode_Access;
   end record;

end EL.Expressions.Nodes;

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

--  The 'ELNode' describes an expression that can later be evaluated
--  on an expression context.  Expressions are parsed and translated
--  to a read-only tree.

with EL.Functions;
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Strings.Unbounded;
with Util.Concurrent.Counters;
private package EL.Expressions.Nodes is

   use EL.Functions;
   use Ada.Strings.Wide_Wide_Unbounded;
   use Ada.Strings.Unbounded;

   type Reduction;

   type ELNode is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

   type ELNode_Access is access all ELNode'Class;

   type Reduction is record
      Node  : ELNode_Access;
      Value : EL.Objects.Object;
   end record;

   --  Evaluate a node on a given context.
   function Get_Value (Expr    : ELNode;
                       Context : ELContext'Class) return Object is abstract;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   function Reduce (Expr    : ELNode;
                    Context : ELContext'Class) return Reduction is abstract;

   --  Delete the expression tree (calls Delete (ELNode_Access) recursively).
   procedure Delete (Node : in out ELNode) is abstract;

   --  Delete the expression tree.  Free the memory allocated by nodes
   --  of the expression tree.  Clears the node pointer.
   procedure Delete (Node : in out ELNode_Access);

   --  ------------------------------
   --  Unary expression node
   --  ------------------------------
   type ELUnary is new ELNode with private;

   type Unary_Node is (EL_VOID, EL_NOT, EL_MINUS);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELUnary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELUnary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELUnary);

   --  ------------------------------
   --  Binary expression node
   --  ------------------------------
   type ELBinary is new ELNode with private;
   type Binary_Node is (EL_EQ, EL_NE, EL_LE, EL_LT, EL_GE, EL_GT,
                        EL_ADD, EL_SUB, EL_MUL, EL_DIV, EL_MOD,
                        EL_AND, EL_OR, EL_LAND, EL_LOR, EL_CONCAT);

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELBinary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELBinary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELBinary);

   --  ------------------------------
   --  Ternary expression node
   --  ------------------------------
   type ELTernary is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELTernary;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELTernary;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELTernary);

   --  ------------------------------
   --  Variable to be looked at in the expression context
   --  ------------------------------
   type ELVariable is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELVariable;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELVariable;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELVariable);

   --  ------------------------------
   --  Value property referring to a variable
   --  ------------------------------
   type ELValue is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELValue;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELValue;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELValue);

   --  ------------------------------
   --  Literal object (integer, boolean, float, string)
   --  ------------------------------
   type ELObject is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELObject;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELObject;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELObject);

   --  ------------------------------
   --  Function call with up to 4 arguments
   --  ------------------------------
   type ELFunction is new ELNode with private;

   --  Evaluate a node on a given context.
   overriding
   function Get_Value (Expr    : ELFunction;
                       Context : ELContext'Class) return Object;

   --  Reduce the expression by eliminating variables which are known
   --  and computing constant expressions.  Returns either a new expression
   --  tree or a constant value.
   overriding
   function Reduce (Expr    : ELFunction;
                    Context : ELContext'Class) return Reduction;

   overriding
   procedure Delete (Node : in out ELFunction);

   --  Create constant nodes
   function Create_Node (Value   : Boolean) return ELNode_Access;
   function Create_Node (Value   : Long_Long_Integer) return ELNode_Access;
   function Create_Node (Value   : String) return ELNode_Access;
   function Create_Node (Value   : Wide_Wide_String) return ELNode_Access;
   function Create_Node (Value   : Long_Float) return ELNode_Access;
   function Create_Node (Value : Unbounded_Wide_Wide_String) return ELNode_Access;
   function Create_Variable (Name : Unbounded_String) return ELNode_Access;
   function Create_Value (Variable : ELNode_Access;
                          Name     : Unbounded_String) return ELNode_Access;

   --  Create unary expressions
   function Create_Node (Of_Type : Unary_Node;
                         Expr    : ELNode_Access) return ELNode_Access;

   --  Create binary expressions
   function Create_Node (Of_Type : Binary_Node;
                         Left    : ELNode_Access;
                         Right   : ELNode_Access) return ELNode_Access;

   --  Create a ternary expression.
   function Create_Node (Cond  : ELNode_Access;
                         Left  : ELNode_Access;
                         Right : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access) return ELNode_Access;

   --  Create a function call
   function Create_Node (Func  : EL.Functions.Function_Access;
                         Arg1  : ELNode_Access;
                         Arg2  : ELNode_Access;
                         Arg3  : ELNode_Access;
                         Arg4  : ELNode_Access) return ELNode_Access;

private

   type ELUnary is new ELNode with record
      Kind : Unary_Node;
      Node : ELNode_Access;
   end record;

   --  ------------------------------
   --  Binary nodes
   --  ------------------------------

   type ELBinary is new ELNode with record
      Kind  : Binary_Node;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  ------------------------------
   --  Ternary expression
   --  ------------------------------
   type ELTernary is new ELNode with record
      Cond  : ELNode_Access;
      Left  : ELNode_Access;
      Right : ELNode_Access;
   end record;

   --  #{bean.name}   - Bean name, Bean property
   --  #{bean[12]}    - Bean name,

   --  Variable to be looked at in the expression context
   type ELVariable is new ELNode with record
      Name     : Unbounded_String;
   end record;

   type ELValue is new ELNode with record
      Name     : Unbounded_String;
      Variable : ELNode_Access;
   end record;

   --  A literal object (integer, boolean, float, String)
   type ELObject is new ELNode with record
      Value : Object;
   end record;

   --  A function call with up to 4 arguments.
   type ELFunction is new ELNode with record
      Func : EL.Functions.Function_Access;
      Arg1 : ELNode_Access;
      Arg2 : ELNode_Access;
      Arg3 : ELNode_Access;
      Arg4 : ELNode_Access;
   end record;

end EL.Expressions.Nodes;

Use a limited type for ELNode so that we can use the portable concurrent counter implementation


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

package body Gen.Commands.Propset is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name);
      use Ada.Strings.Unbounded;

   begin
      if Args.Get_Count /= 2 then
         Gen.Commands.Usage;
         return;
      end if;

      Generator.Read_Project ("dynamo.xml", True);
      Generator.Set_Project_Property (Args.Get_Argument (1), Args.Get_Argument (2));
      Generator.Save_Project;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("propset: Set the value of a property in the dynamo project file");
      Put_Line ("Usage: propset NAME VALUEE");
      New_Line;
   end Help;

end Gen.Commands.Propset;

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

package body Gen.Commands.Propset is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Name);
      use Ada.Strings.Unbounded;

   begin
      if Args.Get_Count /= 2 then
         Cmd.Usage;
         return;
      end if;

      Generator.Read_Project ("dynamo.xml", True);
      Generator.Set_Project_Property (Args.Get_Argument (1), Args.Get_Argument (2));
      Generator.Save_Project;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("propset: Set the value of a property in the dynamo project file");
      Put_Line ("Usage: propset NAME VALUEE");
      New_Line;
   end Help;

end Gen.Commands.Propset;

Use the command usage procedure to report the program usage


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

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

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

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

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

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

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

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

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

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

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

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

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

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

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

      use Util;

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

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

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

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

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

   end Read_Policy;

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

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

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

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

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

end Security.Policies;

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

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      use Util;

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

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

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

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

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

   end Read_Policy;

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

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

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

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

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

end Security.Policies;

Implement the Create_Policy_Contexts operation