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

with AUnit.Test_Caller;
with AUnit.Assertions;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;
package body EL.Objects.Discrete_Tests is

   use EL.Objects;
   use AUnit.Assertions;
   use Ada.Strings.Fixed;

   procedure Test_Eq (V : String; N : Test_Type);
   procedure Test_Conversion (V : String; N : Test_Type);
   procedure Test_Lt_Gt (V : String; N : Test_Type);
   procedure Test_Sub (V : String; N : Test_Type);
   procedure Test_Add (V : String; N : Test_Type);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unreferenced (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test EL.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (V : String; N : Test_Type) is
      Value : EL.Objects.Object;
   begin
      Value := To_Object (V);
      Assert (Condition => To_Type (Value) = N,
              Message   => Test_Name & " returned invalid value: "
              & To_String (Value) & " when we expected: " & V);

      Assert (Condition => V = To_String (Value),
              Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test EL.Objects."+"
   --  ------------------------------
   procedure Test_Add (V : String; N : Test_Type) is
      Value : EL.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      Assert (Condition => To_Type (Value) = N + N,
              Message   => Test_Name & " returned invalid value: "
              & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test EL.Objects."-"
   --  ------------------------------
   procedure Test_Sub (V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : EL.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      Assert (Condition => To_Type (Value) = N - N,
              Message   => Test_Name & " returned invalid value: "
              & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test EL.Objects."<" and EL.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (V : String; N : Test_Type) is
      Res   : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") > 0;
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      Assert (Condition => Res = False,
              Message   => Test_Name & ".'<' returned invalid value: "
              & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      Assert (Condition => Res = False,
              Message   => Test_Name & ".'>' returned invalid value: "
              & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      Assert (Condition => Res = Is_Neg,
              Message   => Test_Name & ".'<' returned invalid value: "
              & Boolean'Image (Res) & " when we expected: "
              & Boolean'Image (Is_Neg)
              & " with value: " & V);
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      Assert (Condition => Res = Is_Neg,
              Message   => Test_Name & ".'>' returned invalid value: "
              & Boolean'Image (Res) & " when we expected: "
              & Boolean'Image (Is_Neg)
              & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         Assert (Condition => Res = not Is_Neg,
                 Message   => Test_Name & ".'<' returned invalid value: "
                 & Boolean'Image (Res) & " when we expected: "
                 & Boolean'Image (not Is_Neg)
                 & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         Assert (Condition => Res = not Is_Neg,
                 Message   => Test_Name & ".'>' returned invalid value: "
                 & Boolean'Image (Res) & " when we expected: "
                 & Boolean'Image (not Is_Neg)
                 & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);

   --  ------------------------------
   --  Test EL.Objects."="
   --  ------------------------------
   procedure Test_Eq (V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      Assert (Condition => Res,
              Message   => Test_Name & ".'=' returned invalid value: "
              & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      Assert (Condition => Res = False,
              Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test EL.Objects."="
   --  ------------------------------
   procedure Test_Perf (V : String; N : Test_Type) is
      use Ada.Calendar;

      Res   : Boolean;
      Start : Ada.Calendar.Time;
      Value : EL.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : EL.Objects.Object := Value;
         begin
            V := V + V;
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test EL.Objects.To_Object." & Test_Name,
                                     Test_To_Object'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.To_String." & Test_Name,
                                     Test_To_Object'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'='." & Test_Name,
                                     Test_Eq'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'+'." & Test_Name,
                                     Test_Add'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'-'." & Test_Name,
                                     Test_Sub'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'<'." & Test_Name,
                                     Test_Lt_Gt'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'>'." & Test_Name,
                                     Test_Lt_Gt'Access));
      Suite.Add_Test (Caller.Create ("Performance EL.Objects.'>'." & Test_Name,
        Test_Perf'Access));
   end Add_Tests;

end EL.Objects.Discrete_Tests;

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

with AUnit.Test_Caller;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;
package body EL.Objects.Discrete_Tests is

   use EL.Objects;
   use Ada.Strings.Fixed;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test EL.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : EL.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test EL.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : EL.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test EL.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : EL.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test EL.Objects."<" and EL.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O : EL.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);

   --  ------------------------------
   --  Test EL.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test EL.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant EL.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : EL.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test EL.Objects.To_Object." & Test_Name,
                                     Test_To_Object'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.To_String." & Test_Name,
                                     Test_To_Object'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'='." & Test_Name,
                                     Test_Eq'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'+'." & Test_Name,
                                     Test_Add'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'-'." & Test_Name,
                                     Test_Sub'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'<'." & Test_Name,
                                     Test_Lt_Gt'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Objects.'>'." & Test_Name,
                                     Test_Lt_Gt'Access));
      Suite.Add_Test (Caller.Create ("Performance EL.Objects.'>'." & Test_Name,
        Test_Perf'Access));
   end Add_Tests;

end EL.Objects.Discrete_Tests;

Fix compilations warnings, use new Aunit assertion methods


with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Streams;
with Interfaces.C.Strings;
with Interfaces.C.Pointers;
with Nanomsg.Errors;
with Nanomsg.Sockopt;
with System;
package body  Nanomsg.Socket is
   package C renames Interfaces.C;
   use type C.Int;

   function Is_Null (Obj : in Socket_T) return Boolean is (Obj.Fd = -1);

   procedure Init (Obj      :    out Socket_T;
                   Domain   : in     Nanomsg.Domains.Domain_T;
                   Protocol : in     Protocol_T
                  ) is

      function C_Nn_Socket (Domain : in C.Int; Protocol : in C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_socket";

   begin
      Obj.Fd := Integer (C_Nn_Socket (Nanomsg.Domains.To_C (Domain),
                                      C.Int (Protocol)));
      if Obj.Fd < 0 then
         raise Socket_Exception with "Init: " & Nanomsg.Errors.Errno_Text;
      end if;
   end Init;

   procedure Close (Obj : in out Socket_T) is
      function C_Nn_Close (Socket : in C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_close";

   begin
      Obj.Delete_Endpoint;
      if C_Nn_Close (C.Int (Obj.Fd)) /= 0 then
         raise Socket_Exception with "Close: " & Nanomsg.Errors.Errno_Text;
      end if;
      Obj.Fd := -1;
   end Close;

   procedure Bind (Obj     : in out Socket_T;
                   Address : in     String) is

      function C_Bind (Socket : in C.Int; Address : in C.Strings.Chars_Ptr) return C.Int
      with Import, Convention => C, External_Name => "nn_bind";
      C_Address : C.Strings.Chars_Ptr := C.Strings.New_String (Address);
   begin
      Obj.Endpoint := Integer (C_Bind(C.Int (Obj.Fd), C_Address));
      C.Strings.Free (C_Address);
      if Obj.Endpoint < -1 then
         raise Socket_Exception with "Bind: "  & Nanomsg.Errors.Errno_Text;
      end if;
      -- FIXME
      -- Add endpoints container
   end Bind;

   procedure Connect (Obj     : in out Socket_T;
                      Address : in     String) is

      function C_Connect (Socket : in C.Int; Address : in C.Strings.Chars_Ptr) return C.Int
      with Import, Convention => C, External_Name => "nn_connect";
      C_Address : C.Strings.Chars_Ptr := C.Strings.New_String (Address);
   begin
      Obj.Endpoint := Integer (C_Connect(C.Int (Obj.Fd), C_Address));
      C.Strings.Free (C_Address);
      if Obj.Endpoint < 0 then
         raise Socket_Exception with "Connect: " & Nanomsg.Errors.Errno_Text;
      end if;
   end Connect;

   function Get_Fd (Obj : in Socket_T) return Integer is (Obj.Fd);

   procedure Receive (Obj : in out Socket_T;
                      Message : out Nanomsg.Messages.Message_T) is

      Payload : System.Address;
      use type System.Address;

      Received : Integer;
      use type C.Size_T;
      Flags : constant C.Int := 0;
      Nn_Msg : constant C.Size_T := C.Size_T'Last;

      function Nn_Recv (Socket     :     C.Int;
                        Buf_Access : out System.Address;
                        Size       :     C.Size_T;
                        Flags      :     C.Int
                       ) return C.Int with Import, Convention => C, External_Name => "nn_recv";

      function Free_Msg (Buf_Access :System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_freemsg";
   begin
      Received := Integer (Nn_Recv (C.Int (Obj.Fd), Payload, Nn_Msg, Flags));
      if Received < 0 then
         raise Socket_Exception with "Receive: " & Nanomsg.Errors.Errno_Text;
      end if;
      Message.Set_Length (Received);
      declare
         Data :  Ada.Streams.Stream_Element_Array (1 .. Ada.Streams.Stream_Element_Offset (Received));
         for Data'Address use Payload;
      begin
         Message.Set_Payload (Data);
      end;
      if Free_Msg (Payload) < 0 then
         raise Socket_Exception with "Deallocation failed";
      end if;
   end Receive;

   procedure Send (Obj : in Socket_T; Message : Nanomsg.Messages.Message_T) is
      Flags : C.Int := 0;
      function Nn_Send (Socket     : C.Int;
                        Buf_Access : Ada.Streams.Stream_Element_Array;
                        Size       : C.Size_T;
                        Flags      : C.Int
                       ) return C.Int with Import, Convention => C, External_Name => "nn_send";
      Sent : Integer;
   begin

      Sent := Integer (Nn_Send (C.Int (Obj.Fd),
                                Message.Get_Payload.all,
                                C.Size_T (Message.Get_Length),
                                Flags));
      if Sent < 0 then
         raise Socket_Exception with "Send: " & Nanomsg.Errors.Errno_Text;
      end if;
      if Sent /= Message.Get_Length then
         raise Socket_Exception with "Send/Receive count doesn't match";
      end if;
   end Send;

   procedure Delete_Endpoint (Obj : in out Socket_T) is
      function Nn_Shutdown (Socket : C.Int;
                            Endpoint : C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_shutdown";
   begin
      if Obj.Endpoint > 0 then
         if Nn_Shutdown (C.Int (Obj.Fd), C.Int (Obj.Endpoint)) < 0 then
            raise Socket_Exception with "Shutdown Error" &  Nanomsg.Errors.Errno_Text;
         end if;
         Obj.Endpoint := -1;
      end if;
   end Delete_Endpoint;

   function C_Setsockopt (Socket : C.Int;
                          Level  : C.Int;
			  Option : C.Int;
			  Value  : System.Address;
			  Size   : C.Size_T) return C.Int with Import, Convention => C, External_Name => "nn_setsockopt";

   procedure Set_Option (Obj   : in out Socket_T;
                         Level : in     Nanomsg.Sockopt.Option_Level_T;
                         Name  : in     Nanomsg.Sockopt.Option_Type_T;
                         Value : in     Natural)
   is
      use Nanomsg.Sockopt;
      Size : C.Size_T := C.Size_T (C.Int'Size);
   begin
      begin
         if C_Setsockopt (C.Int (Obj.Fd),
                          C.Int (Level),
                          C.Int (Name),
                          Value'Address,
                          Size) < 0 then
            raise Socket_Exception with "Setopt error";
         end if;
      end;
   end Set_Option;

   procedure Set_Option (Obj   : in out Socket_T;
                         Level : in     Nanomsg.Sockopt.Option_Level_T;
                         Name  : in     Nanomsg.Sockopt.Option_Type_T;
                         Value : in     String) is
      C_Value : C.Strings.Char_Array_Access := new C.Char_Array'(C.To_C (Value)) with Convention => C;
      procedure Free is new Ada.Unchecked_Deallocation (Name	=> C.Strings.Char_Array_Access,
							Object	=> C.Char_Array);
      Size	: C.Size_T	:= C_Value'Length;
   begin
      if C_Setsockopt (C.Int (Obj.Fd),
                       C.Int (Level),
                       C.Int (Name),
                       C_Value.all'Address,
                       Size) < 0 then
         raise Socket_Exception with "Setopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      Free (C_Value);
   end Set_Option;

   function Get_Option (Obj   : in Socket_T;
                        Level : in Nanomsg.Sockopt.Option_Level_T;
                        Name  : in Nanomsg.Sockopt.Option_Type_T) return String is
      type String_Access_T is access all String;
      procedure Free is new Ada.Unchecked_Deallocation (Name => String_Access_T,
							Object => String);

      function Nn_Getsockopt (Socket	  : in 	   C.Int;
			      Level	  : in 	   C.Int;
			      Option_Name : in 	   C.Int;
			      Value	  : in out String_Access_T;
			      Size	  : in 	   System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_getsockopt";

      use Nanomsg.Sockopt;
      Max_Size : constant := 63;
      Ptr : String_Access_T := new String(1..Max_Size);
      Size	: C.Size_T := Max_Size;
      use type C.Size_T;
   begin
      if Nn_Getsockopt (Socket		=> C.Int (Obj.Fd),
			Level		=> C.Int (Level),
			Option_Name	=> C.Int (Name),
			Value		=> Ptr,
			Size		=> Size'Address) < 0 then
	 raise Socket_Exception with "Getopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      declare
         Retval : constant String := Ptr.all(1.. Integer (Size));
      begin
	 Free (Ptr);
         return Retval;
      end;
   end Get_Option;

   function Get_Option (Obj   : in Socket_T;
                        Level : in Nanomsg.Sockopt.Option_Level_T;
                        Name  : in Nanomsg.Sockopt.Option_Type_T) return Natural is
      Retval : Natural;
      Size : C.Size_T := C.Int'Size;
      function Nn_Getsockopt (Socket	  : in 	   C.Int;
			      Level	  : in 	   C.Int;
			      Option_Name : in 	   C.Int;
			      Value	  : in out C.Int;
			      Size	  : in 	   System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_getsockopt";
   begin
      if Nn_Getsockopt (Socket		=> C.Int (Obj.Fd),
			Level		=> C.Int (Level),
			Option_Name	=> C.Int (Name),
			Value		=> C.Int (Retval),
			Size		=> Size'Address) < 0 then
	 raise Socket_Exception with "Getopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      return Retval;
   end Get_Option;

end Nanomsg.Socket;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Streams;
with Interfaces.C.Strings;
with Interfaces.C.Pointers;
with Nanomsg.Errors;
with Nanomsg.Sockopt;
with System;
package body  Nanomsg.Socket is
   package C renames Interfaces.C;
   use type C.Int;

   function Is_Null (Obj : in Socket_T) return Boolean is (Obj.Fd = -1);

   procedure Init (Obj      :    out Socket_T;
                   Domain   : in     Nanomsg.Domains.Domain_T;
                   Protocol : in     Protocol_T
                  ) is

      function C_Nn_Socket (Domain : in C.Int; Protocol : in C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_socket";

   begin
      Obj.Fd := Integer (C_Nn_Socket (Nanomsg.Domains.To_C (Domain),
                                      C.Int (Protocol)));
      if Obj.Fd < 0 then
         raise Socket_Exception with "Init: " & Nanomsg.Errors.Errno_Text;
      end if;
   end Init;

   procedure Close (Obj : in out Socket_T) is
      function C_Nn_Close (Socket : in C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_close";

   begin
      Obj.Delete_Endpoint;
      if C_Nn_Close (C.Int (Obj.Fd)) /= 0 then
         raise Socket_Exception with "Close: " & Nanomsg.Errors.Errno_Text;
      end if;
      Obj.Fd := -1;
   end Close;

   procedure Bind (Obj     : in out Socket_T;
                   Address : in     String) is

      function C_Bind (Socket : in C.Int; Address : in C.Strings.Chars_Ptr) return C.Int
      with Import, Convention => C, External_Name => "nn_bind";
      C_Address : C.Strings.Chars_Ptr := C.Strings.New_String (Address);
   begin
      Obj.Endpoint := Integer (C_Bind(C.Int (Obj.Fd), C_Address));
      C.Strings.Free (C_Address);
      if Obj.Endpoint < -1 then
         raise Socket_Exception with "Bind: "  & Nanomsg.Errors.Errno_Text;
      end if;
      -- FIXME
      -- Add endpoints container
   end Bind;

   procedure Connect (Obj     : in out Socket_T;
                      Address : in     String) is

      function C_Connect (Socket : in C.Int; Address : in C.Strings.Chars_Ptr) return C.Int
      with Import, Convention => C, External_Name => "nn_connect";
      C_Address : C.Strings.Chars_Ptr := C.Strings.New_String (Address);
   begin
      Obj.Endpoint := Integer (C_Connect(C.Int (Obj.Fd), C_Address));
      C.Strings.Free (C_Address);
      if Obj.Endpoint < 0 then
         raise Socket_Exception with "Connect: " & Nanomsg.Errors.Errno_Text;
      end if;
   end Connect;

   function Get_Fd (Obj : in Socket_T) return Integer is (Obj.Fd);

   procedure Receive (Obj : in out Socket_T;
                      Message : out Nanomsg.Messages.Message_T) is

      Payload : System.Address;
      use type System.Address;

      Received : Integer;
      use type C.Size_T;
      Flags : constant C.Int := 0;
      Nn_Msg : constant C.Size_T := C.Size_T'Last;

      function Nn_Recv (Socket     :     C.Int;
                        Buf_Access : out System.Address;
                        Size       :     C.Size_T;
                        Flags      :     C.Int
                       ) return C.Int with Import, Convention => C, External_Name => "nn_recv";

      function Free_Msg (Buf_Access :System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_freemsg";
   begin
      Received := Integer (Nn_Recv (C.Int (Obj.Fd), Payload, Nn_Msg, Flags));
      if Received < 0 then
         raise Socket_Exception with "Receive: " & Nanomsg.Errors.Errno_Text;
      end if;
      Message.Set_Length (Received);
      declare
         Data :  Ada.Streams.Stream_Element_Array (1 .. Ada.Streams.Stream_Element_Offset (Received));
         for Data'Address use Payload;
      begin
         Message.Set_Payload (Data);
      end;
      if Free_Msg (Payload) < 0 then
         raise Socket_Exception with "Deallocation failed";
      end if;
   end Receive;

   procedure Send (Obj : in Socket_T; Message : Nanomsg.Messages.Message_T) is
      Flags : C.Int := 0;
      function Nn_Send (Socket     : C.Int;
                        Buf_Access : Ada.Streams.Stream_Element_Array;
                        Size       : C.Size_T;
                        Flags      : C.Int
                       ) return C.Int with Import, Convention => C, External_Name => "nn_send";
      Sent : Integer;
   begin

      Sent := Integer (Nn_Send (C.Int (Obj.Fd),
                                Message.Get_Payload.all,
                                C.Size_T (Message.Get_Length),
                                Flags));
      if Sent < 0 then
         raise Socket_Exception with "Send: " & Nanomsg.Errors.Errno_Text;
      end if;
      if Sent /= Message.Get_Length then
         raise Socket_Exception with "Send/Receive count doesn't match";
      end if;
   end Send;

   procedure Delete_Endpoint (Obj : in out Socket_T) is
      function Nn_Shutdown (Socket : C.Int;
                            Endpoint : C.Int) return C.Int
      with Import, Convention => C, External_Name => "nn_shutdown";
   begin
      if Obj.Endpoint > 0 then
         if Nn_Shutdown (C.Int (Obj.Fd), C.Int (Obj.Endpoint)) < 0 then
            raise Socket_Exception with "Shutdown Error" &  Nanomsg.Errors.Errno_Text;
         end if;
         Obj.Endpoint := -1;
      end if;
   end Delete_Endpoint;

   function C_Setsockopt (Socket : C.Int;
                          Level  : C.Int;
			  Option : C.Int;
			  Value  : System.Address;
			  Size   : C.Size_T) return C.Int with Import, Convention => C, External_Name => "nn_setsockopt";

   procedure Set_Option (Obj   : in out Socket_T;
                         Level : in     Nanomsg.Sockopt.Option_Level_T;
                         Name  : in     Nanomsg.Sockopt.Option_Type_T;
                         Value : in     Natural)
   is
      use Nanomsg.Sockopt;
      Size : C.Size_T := C.Size_T (C.Int'Size);
   begin
      begin
         if C_Setsockopt (C.Int (Obj.Fd),
                          C.Int (Level),
                          C.Int (Name),
                          Value'Address,
                          Size) < 0 then
            raise Socket_Exception with "Setopt error";
         end if;
      end;
   end Set_Option;

   procedure Set_Option (Obj   : in out Socket_T;
                         Level : in     Nanomsg.Sockopt.Option_Level_T;
                         Name  : in     Nanomsg.Sockopt.Option_Type_T;
                         Value : in     String) is
      C_Value : C.Strings.Char_Array_Access := new C.Char_Array'(C.To_C (Value)) with Convention => C;
      procedure Free is new Ada.Unchecked_Deallocation (Name	=> C.Strings.Char_Array_Access,
							Object	=> C.Char_Array);
      use type C.Size_T;
      Size	: C.Size_T	:= C_Value'Length - 1;
   begin
      if C_Setsockopt (C.Int (Obj.Fd),
                       C.Int (Level),
                       C.Int (Name),
                       C_Value.all'Address,
                       Size) < 0 then
         raise Socket_Exception with "Setopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      Free (C_Value);
   end Set_Option;

   function Get_Option (Obj   : in Socket_T;
                        Level : in Nanomsg.Sockopt.Option_Level_T;
                        Name  : in Nanomsg.Sockopt.Option_Type_T) return String is
      type String_Access_T is access all String;
      procedure Free is new Ada.Unchecked_Deallocation (Name => String_Access_T,
							Object => String);

      function Nn_Getsockopt (Socket	  : in 	   C.Int;
			      Level	  : in 	   C.Int;
			      Option_Name : in 	   C.Int;
			      Value	  : in out String_Access_T;
			      Size	  : in 	   System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_getsockopt";

      use Nanomsg.Sockopt;
      Max_Size : constant := 63;
      Ptr : String_Access_T := new String(1..Max_Size);
      Size	: C.Size_T := Max_Size;
      use type C.Size_T;
   begin
      if Nn_Getsockopt (Socket		=> C.Int (Obj.Fd),
			Level		=> C.Int (Level),
			Option_Name	=> C.Int (Name),
			Value		=> Ptr,
			Size		=> Size'Address) < 0 then
	 raise Socket_Exception with "Getopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      declare
         Retval : constant String := Ptr.all(1.. Integer (Size));
      begin
	 Free (Ptr);
         return Retval;
      end;
   end Get_Option;

   function Get_Option (Obj   : in Socket_T;
                        Level : in Nanomsg.Sockopt.Option_Level_T;
                        Name  : in Nanomsg.Sockopt.Option_Type_T) return Natural is
      Retval : Natural;
      Size : C.Size_T := C.Int'Size;
      function Nn_Getsockopt (Socket	  : in 	   C.Int;
			      Level	  : in 	   C.Int;
			      Option_Name : in 	   C.Int;
			      Value	  : in out C.Int;
			      Size	  : in 	   System.Address) return C.Int
      with Import, Convention => C, External_Name => "nn_getsockopt";
   begin
      if Nn_Getsockopt (Socket		=> C.Int (Obj.Fd),
			Level		=> C.Int (Level),
			Option_Name	=> C.Int (Name),
			Value		=> C.Int (Retval),
			Size		=> Size'Address) < 0 then
	 raise Socket_Exception with "Getopt error"  &  Nanomsg.Errors.Errno_Text;
      end if;
      return Retval;
   end Get_Option;

end Nanomsg.Socket;

Fix string length calculation

Fix string length calculation

Do not include trailing \0 into account to avoid subscription to messages
started with \0.


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 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;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

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

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

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value);

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

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

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

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

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

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access);

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl = null then
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      end if;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Util.Concurrent.Counters.Increment (Bundle.Impl.Count);
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in Value)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      --  ------------------------------
      --  Returns the property value.  Raises an exception if not found.
      --  ------------------------------
      function Get (Self : in Manager; Name : in Value)
                   return Value is
      begin
         return Self.Props.Get (Name);

      exception
         when NO_PROPERTY =>
            declare
               Iter : Cursor := Self.List.First;
            begin
               while Has_Element (Iter) loop
                  begin
                     return Element (Iter).all.Get (Name);
                  exception
                     when NO_PROPERTY =>
                        Iter := Next (Iter);
                  end;
               end loop;
            end;
            raise;
      end Get;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      procedure Insert (Self : in out Manager;
                        Name : in Value;
                        Item : in Value) is
         pragma Unreferenced (Self);
         pragma Unreferenced (Name);
         pragma Unreferenced (Item);
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Insert;

      --  ------------------------------
      --  Set the value of the property.  The property is created if it
      --  does not exists.
      --  ------------------------------
      procedure Set (Self : in out Manager;
                     Name : in Value;
                     Item : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Delete (Self : in Manager;
                        Obj : in out Util.Properties.Interface_P.Manager_Access) is
         pragma Unreferenced (Self);
         Item : Manager_Object_Access := Manager (Obj.all)'Access;
      begin
         Free (Item);
      end Delete;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter   : constant Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object;

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

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

      --  Remove the property given its name.
      overriding
      procedure Remove (Self : in out Manager; Name : in Value);

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

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

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

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl = null then
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      end if;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Util.Concurrent.Counters.Increment (Bundle.Impl.Count);
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object is
         Result : Util.Beans.Objects.Object := From.Props.Get_Value (Name);
      begin
         if Util.Beans.Objects.Is_Null (Result) then
            declare
               Iter : Cursor := From.List.First;
            begin
               while Has_Element (Iter) loop
                  Result := Element (Iter).all.Get_Value (Name);
                  exit when not Util.Beans.Objects.Is_Null (Result);
                  Iter := Next (Iter);
               end loop;
            end;
         end if;
         return Result;
      end Get_Value;

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

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in String)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter   : constant Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

Refactor the Properties implementation (step 2): - update the bundles implementation for the new properties implementation


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

   use Interfaces;

   type Attribute_Type is (T_UINT8,
                           T_UINT16,
                           T_UINT32,
                           T_UINT64,
                           T_POINTER,
                           T_PROBE,
                           T_FRAME,
                           T_THREAD,
                           T_TIME,
                           T_SIZE_T);

   type Event_Type is new Interfaces.Unsigned_32;

   subtype Internal_Reference is Natural;

   type Attribute is record
      Name : Util.Strings.Name_Access;
      Size : Natural            := 0;
      Kind : Attribute_Type     := T_UINT8;
      Ref  : Internal_Reference := 0;
   end record;
   --  Logical description of an event attribute.

   type Attribute_Table is array (Natural range <>) of Attribute;
   type Attribute_Table_Ptr is access all Attribute_Table;
   type Const_Attribute_Table_Access is access constant Attribute_Table;

   type Event_Description (Nb_Attributes : Natural) is record
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Id   : Unsigned_32;
      Kind : Event_Type;
      Def  : Attribute_Table (1 .. Nb_Attributes);
   end record;
   type Event_Description_Ptr is access all Event_Description;
   subtype Addr is MAT.Types.Uint32;
   type Frame_Table is array (Natural range <>) of Addr;

   type Rusage_Info is record
      Minflt : Unsigned_32;
      Majflt : Unsigned_32;
      Nswap  : Unsigned_32;
   end record;

   type Frame_Info (Depth : Natural) is record
      Time   : Unsigned_64;
      Thid   : Unsigned_32;
      Thstk  : Unsigned_32;
      Rusage : Rusage_Info;
      Cur_Depth : Unsigned_32;
      Frame  : Frame_Table (1 .. Depth);
   end record;

   type Event_Data is record
      Kind  : Attribute_Type;
      U8    : MAT.Types.Uint8;
      U16   : MAT.Types.Uint16;
      U32   : MAT.Types.Uint32;
      U64   : MAT.Types.Uint64;
      Probe : Frame_Info (Depth => 10);
   end record;

   type Event_Data_Table is array (Natural range <>) of Event_Data;

   procedure Dump (Table : in Event_Data_Table;
                   Def   : in Event_Description);

end MAT.Events;

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

   use Interfaces;

   type Attribute_Type is (T_UINT8,
                           T_UINT16,
                           T_UINT32,
                           T_UINT64,
                           T_POINTER,
                           T_PROBE,
                           T_FRAME,
                           T_THREAD,
                           T_TIME,
                           T_SIZE_T);

   type Event_Type is new Interfaces.Unsigned_32;

   subtype Internal_Reference is Natural;

   type Attribute is record
      Name : Util.Strings.Name_Access;
      Size : Natural            := 0;
      Kind : Attribute_Type     := T_UINT8;
      Ref  : Internal_Reference := 0;
   end record;
   --  Logical description of an event attribute.

   type Attribute_Table is array (Natural range <>) of Attribute;
   type Attribute_Table_Ptr is access all Attribute_Table;
   type Const_Attribute_Table_Access is access constant Attribute_Table;

   type Event_Description (Nb_Attributes : Natural) is record
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Id   : Unsigned_32;
      Kind : Event_Type;
      Def  : Attribute_Table (1 .. Nb_Attributes);
   end record;
   type Event_Description_Ptr is access all Event_Description;
   subtype Addr is MAT.Types.Uint32;
   type Frame_Table is array (Natural range <>) of Addr;

   type Rusage_Info is record
      Minflt : Unsigned_32;
      Majflt : Unsigned_32;
      Nswap  : Unsigned_32;
   end record;

   type Frame_Info (Depth : Natural) is record
      Time      : MAT.Types.Target_Time;
      Thread    : MAT.Types.Target_Thread_Ref;
      Stack     : MAT.Types.Target_Addr;
      Rusage    : Rusage_Info;
      Cur_Depth : Natural;
      Frame     : Frame_Table (1 .. Depth);
   end record;

   type Event_Data is record
      Kind  : Attribute_Type;
      U8    : MAT.Types.Uint8;
      U16   : MAT.Types.Uint16;
      U32   : MAT.Types.Uint32;
      U64   : MAT.Types.Uint64;
      Probe : Frame_Info (Depth => 10);
   end record;

   type Event_Data_Table is array (Natural range <>) of Event_Data;

   procedure Dump (Table : in Event_Data_Table;
                   Def   : in Event_Description);

end MAT.Events;

Fix the Frame_Info type

Fix the Frame_Info type