-----------------------------------------------------------------------
--  util-systems-os -- Unix system operations
--  Copyright (C) 2011, 2012, 2014, 2015, 2016, 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.
-----------------------------------------------------------------------

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;
with Util.Systems.Types;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.LF;

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   subtype File_Type is Util.Systems.Types.File_Type;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   use type Util.Systems.Types.File_Type;  --  This use clause is required by GNAT 2018 for the -1!
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => "close";

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => "read";

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => "write";

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer)
    with Import => True, Convention => C, Link_Name => "_exit";

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier
     with Import => True, Convention => C, Link_Name => "fork";

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier
     with Import => True, Convention => C, Link_Name => "fork";

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => "execvp";

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => "waitpid";

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer
     with Import => True, Convention => C, Link_Name => "pipe";

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => "dup2";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => "close";

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type
     with Import => True, Convention => C, Link_Name => "open";

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer
     with Import => True, Convention => C, Link_Name => "fcntl";

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => "kill";

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.STAT_NAME;

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.FSTAT_NAME;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t
     with Import => True, Convention => C, Link_Name => "lseek";

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => "ftruncate";

   function Sys_Truncate (Path  : in Ptr;
                          Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => "truncate";

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => "fchmod";

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => "chmod";

   --  Change working directory.
   function Sys_Chdir (Path : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => "chdir";

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in Ptr;
                        Newpath  : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => "rename";

   --  Libc errno.  The __get_errno function is provided by the GNAT runtime.
   function Errno return Integer
     with Import => True, Convention => C, Link_Name => "__get_errno";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => C, Link_Name => "strerror";

end Util.Systems.Os;

-----------------------------------------------------------------------
--  util-systems-os -- Unix system operations
--  Copyright (C) 2011, 2012, 2014, 2015, 2016, 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.
-----------------------------------------------------------------------

with System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;
with Util.Systems.Types;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   --  The path separator.
   Path_Separator      : constant Character := ':';

   --  The line ending separator.
   Line_Separator      : constant String := "" & ASCII.LF;

   use Util.Systems.Constants;

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   subtype File_Type is Util.Systems.Types.File_Type;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   use type Util.Systems.Types.File_Type;  --  This use clause is required by GNAT 2018 for the -1!
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "read";

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "write";

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer)
    with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "exit";

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fork";

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "execvp";

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "waitpid";

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "pipe";

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "dup2";

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "close";

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "open";

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fcntl";

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "kill";

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.STAT_NAME;

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer
     with Import => True, Convention => C, Link_Name => Util.Systems.Types.FSTAT_NAME;

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "lseek";

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "ftruncate";

   function Sys_Truncate (Path  : in Ptr;
                          Length : in Util.Systems.Types.off_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "truncate";

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "fchmod";

   --  Change permission of a file.
   function Sys_Chmod (Path  : in Ptr;
                       Mode  : in Util.Systems.Types.mode_t) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chmod";

   --  Change working directory.
   function Sys_Chdir (Path : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "chdir";

   --  Rename a file (the Ada.Directories.Rename does not allow to use
   --  the Unix atomic file rename!)
   function Sys_Rename (Oldpath  : in Ptr;
                        Newpath  : in Ptr) return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "rename";

   --  Libc errno.  The __get_errno function is provided by the GNAT runtime.
   function Errno return Integer
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "_get_errno";

   function Strerror (Errno : in Integer) return Interfaces.C.Strings.chars_ptr
     with Import => True, Convention => C, Link_Name => SYMBOL_PREFIX & "strerror";

end Util.Systems.Os;

Allow to have an optional symbol prefix when we import system call symbols


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

with Util.Log.Loggers;
with MAT.Types;
with MAT.Readers.Marshaller;
package body MAT.Readers.Streams is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Files");

   MAX_MSG_SIZE : constant Ada.Streams.Stream_Element_Offset := 2048;

   --  ------------------------------
   --  Read a message from the stream.
   --  ------------------------------
   overriding
   procedure Read_Message (Reader : in out Stream_Reader_Type;
                           Msg    : in out Message_Type) is
      use type Ada.Streams.Stream_Element_Offset;

      Buffer : constant Util.Streams.Buffered.Buffer_Access := Msg.Buffer.Buffer;
      Last   : Ada.Streams.Stream_Element_Offset;
   begin
      Reader.Stream.Read (Buffer (0 .. 1), Last);
      if Last /= 2 then
         raise Ada.IO_Exceptions.End_Error;
      end if;
      Msg.Buffer.Size := 2;
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Size := Natural (MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer));
      if Msg.Size < 2 then
         Log.Error ("Invalid message size {0}", Natural'Image (Msg.Size));
      end if;
      if Ada.Streams.Stream_Element_Offset (Msg.Size) >= Buffer'Last then
         Log.Error ("Message size {0} is too big", Natural'Image (Msg.Size));
         raise Ada.IO_Exceptions.Data_Error;
      end if;
      Reader.Stream.Read (Buffer (0 .. Ada.Streams.Stream_Element_Offset (Msg.Size - 1)), Last);
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last    := Buffer (Last)'Address;
      Msg.Buffer.Size    := Msg.Size;
      Log.Debug ("Read message size {0}", Natural'Image (Msg.Size));
   end Read_Message;

   --  ------------------------------
   --  Read the events from the stream and stop when the end of the stream is reached.
   --  ------------------------------
   procedure Read_All (Reader : in out Stream_Reader_Type) is
      use Ada.Streams;
      use type MAT.Types.Uint8;

      Buffer  : aliased Buffer_Type;
      Msg     : Message;
      Last    : Ada.Streams.Stream_Element_Offset;
      Format  : MAT.Types.Uint8;
   begin
      Reader.Data := new Ada.Streams.Stream_Element_Array (0 .. MAX_MSG_SIZE);
      Msg.Buffer := Buffer'Unchecked_Access;
      Msg.Buffer.Start := Reader.Data (0)'Address;
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last := Reader.Data (MAX_MSG_SIZE)'Address;
      Msg.Buffer.Size := 1;
      Buffer.Buffer := Reader.Data;
      Reader.Stream.Read (Reader.Data (0 .. 0), Last);
      Format := MAT.Readers.Marshaller.Get_Uint8 (Msg.Buffer);
      if Format = 0 then
         Msg.Buffer.Endian := LITTLE_ENDIAN;
         Log.Debug ("Data stream is little endian");
      else
         Msg.Buffer.Endian := BIG_ENDIAN;
         Log.Debug ("Data stream is big endian");
      end if;
      Reader.Read_Message (Msg);
      Reader.Read_Event_Definitions (Msg);
      while not Reader.Stream.Is_Eof loop
         Reader.Read_Message (Msg);
         Reader.Dispatch_Message (Msg);
      end loop;

   exception
      when Ada.IO_Exceptions.End_Error =>
         null;

   end Read_All;

end MAT.Readers.Streams;

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

with Util.Log.Loggers;
with MAT.Types;
with MAT.Readers.Marshaller;
package body MAT.Readers.Streams is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Files");

   MAX_MSG_SIZE : constant Ada.Streams.Stream_Element_Offset := 4096;

   --  ------------------------------
   --  Read a message from the stream.
   --  ------------------------------
   overriding
   procedure Read_Message (Reader : in out Stream_Reader_Type;
                           Msg    : in out Message_Type) is
      use type Ada.Streams.Stream_Element_Offset;

      Buffer : constant Util.Streams.Buffered.Buffer_Access := Msg.Buffer.Buffer;
      Last   : Ada.Streams.Stream_Element_Offset;
   begin
      Reader.Stream.Read (Buffer (0 .. 1), Last);
      if Last /= 2 then
         raise Ada.IO_Exceptions.End_Error;
      end if;
      Msg.Buffer.Size := 2;
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Size := Natural (MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer));
      if Msg.Size < 2 then
         Log.Error ("Invalid message size {0}", Natural'Image (Msg.Size));
      end if;
      if Ada.Streams.Stream_Element_Offset (Msg.Size) >= Buffer'Last then
         Log.Error ("Message size {0} is too big", Natural'Image (Msg.Size));
         raise Ada.IO_Exceptions.Data_Error;
      end if;
      Reader.Stream.Read (Buffer (0 .. Ada.Streams.Stream_Element_Offset (Msg.Size - 1)), Last);
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last    := Buffer (Last)'Address;
      Msg.Buffer.Size    := Msg.Size;
      Log.Debug ("Read message size {0}", Natural'Image (Msg.Size));
   end Read_Message;

   --  ------------------------------
   --  Read the events from the stream and stop when the end of the stream is reached.
   --  ------------------------------
   procedure Read_All (Reader : in out Stream_Reader_Type) is
      use Ada.Streams;
      use type MAT.Types.Uint8;

      Buffer  : aliased Buffer_Type;
      Msg     : Message;
      Last    : Ada.Streams.Stream_Element_Offset;
      Format  : MAT.Types.Uint8;
   begin
      Reader.Data := new Ada.Streams.Stream_Element_Array (0 .. MAX_MSG_SIZE);
      Msg.Buffer := Buffer'Unchecked_Access;
      Msg.Buffer.Start := Reader.Data (0)'Address;
      Msg.Buffer.Current := Msg.Buffer.Start;
      Msg.Buffer.Last := Reader.Data (MAX_MSG_SIZE)'Address;
      Msg.Buffer.Size := 1;
      Buffer.Buffer := Reader.Data;
      Reader.Stream.Read (Reader.Data (0 .. 0), Last);
      Format := MAT.Readers.Marshaller.Get_Uint8 (Msg.Buffer);
      if Format = 0 then
         Msg.Buffer.Endian := LITTLE_ENDIAN;
         Log.Debug ("Data stream is little endian");
      else
         Msg.Buffer.Endian := BIG_ENDIAN;
         Log.Debug ("Data stream is big endian");
      end if;
      Reader.Read_Message (Msg);
      Reader.Read_Event_Definitions (Msg);
      while not Reader.Stream.Is_Eof loop
         Reader.Read_Message (Msg);
         Reader.Dispatch_Message (Msg);
      end loop;

   exception
      when Ada.IO_Exceptions.End_Error =>
         null;

   end Read_All;

end MAT.Readers.Streams;

Increase the max message size to 4K

Increase the max message size to 4K


-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 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 ASF.Applications;

with ASF.Security.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @include users.xml
--
--  @include awa-users-services.ads
--
--  @include users.xml
--
--  == Data Model ==
--  @include User.hbm.xml
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

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

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 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 ASF.Applications;

with ASF.Security.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @include users.xml
--
--  @include awa-users-services.ads
--
--  @include users.xml
--
--  == Model ==
--  [http://ada-awa.googlecode.com/svn/wiki/awa_user_model.png]
--
--  @include User.hbm.xml
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

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

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased ASF.Security.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

Update the user module documentation

Update the user module documentation


-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 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 ASF.Applications;

with Security.Openid.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @include awa-users-services.ads
--  @include User.hbm.xml
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

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

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased Security.Openid.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 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 ASF.Applications;

with Security.Openid.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @include awa-users-services.ads
--
--  @include users.xml
--
--  == Data Model ==
--  @include User.hbm.xml
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

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

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased Security.Openid.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

Add the user module Ada beans in the documentation


-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Requests.Tools;
with ASF.Servlets.Faces;
with Ada.Directories;

with Util.Test_Caller;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);
      App.Register_Application ("/");
      App.Add_Servlet ("faces", Faces'Unchecked_Access);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : aliased ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin
            ASF.Requests.Tools.Set_Context (Req      => Req,
                                            Servlet  => Faces'Unchecked_Access,
                                            Response => Rep'Unchecked_Access);
            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) /= Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Requests.Tools;
with ASF.Servlets.Faces;
with Ada.Directories;

with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Faces       : aliased ASF.Servlets.Faces.Faces_Servlet;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);
      App.Register_Application ("/");
      App.Add_Servlet ("faces", Faces'Unchecked_Access);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : aliased ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin
            ASF.Requests.Tools.Set_Context (Req      => Req,
                                            Servlet  => Faces'Unchecked_Access,
                                            Response => Rep'Unchecked_Access);
            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) /= Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

Fix compilation warning

Fix compilation warning


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

with MAT.Types;
with MAT.Readers.Marshaller;
with MAT.Memory;
package body MAT.Memory.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Probes");

   M_SIZE     : constant MAT.Events.Internal_Reference := 1;
   M_FRAME    : constant MAT.Events.Internal_Reference := 2;
   M_ADDR     : constant MAT.Events.Internal_Reference := 3;
   M_OLD_ADDR : constant MAT.Events.Internal_Reference := 4;
   M_THREAD   : constant MAT.Events.Internal_Reference := 5;
   M_UNKNOWN  : constant MAT.Events.Internal_Reference := 6;
   M_TIME     : constant MAT.Events.Internal_Reference := 7;
   --  Defines the possible data kinds which are recognized by
   --  the memory unmarshaller.  All others are ignored.

   SIZE_NAME  : aliased constant String := "size";
   FRAME_NAME : aliased constant String := "frame";
   ADDR_NAME  : aliased constant String := "pointer";
   OLD_NAME   : aliased constant String := "old-pointer";
   THREAD_NAME : aliased constant String := "thread";
   TIME_NAME   : aliased constant String := "time";

   Memory_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_SIZE),
      2 => (Name => FRAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FRAME),
      3 => (Name => ADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      4 => (Name => OLD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_OLD_ADDR),
      5 => (Name => THREAD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_THREAD, Ref => M_THREAD),
      6 => (Name => TIME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_TIME, Ref => M_TIME));

   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table);

   ----------------------
   --  Register the reader to extract and analyze memory events.
   ----------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Memory_Probe_Type_Access) is
   begin
      Into.Register_Probe (Probe.all'Access, "malloc", MAT.Events.Targets.MSG_MALLOC,
                           Memory_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "free", MAT.Events.Targets.MSG_FREE,
                           Memory_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "realloc", MAT.Events.Targets.MSG_REALLOC,
                           Memory_Attributes'Access);
   end Register;

   ----------------------
   --  Unmarshall from the message the memory slot information.
   --  The data is described by the Defs table.
   ----------------------
   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message_Type;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table) is
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_SIZE =>
                  Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

               when M_ADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_OLD_ADDR =>
                  Old_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_UNKNOWN =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);

            end case;
         end;
      end loop;
   end Unmarshall_Allocation;

   --  Extract the probe information from the message.
   overriding
   procedure Extract (Probe   : in Memory_Probe_Type;
                      Params  : in MAT.Events.Const_Attribute_Table_Access;
                      Msg     : in out MAT.Readers.Message_Type;
                      Event   : in out MAT.Events.Targets.Probe_Event_Type) is
   begin
      case Event.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MAT.Events.Targets.MSG_FREE =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MAT.Events.Targets.MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when others =>
            raise Program_Error;

      end case;
   end Extract;

   procedure Execute (Probe : in Memory_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
      Slot     : Allocation;
   begin
      Slot.Size   := Event.Size;
      Slot.Thread := Event.Thread;
      Slot.Time   := Event.Time;
      Slot.Frame  := Event.Frame;
      case Event.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            Probe.Data.Probe_Malloc (Event.Addr, Slot);

         when MAT.Events.Targets.MSG_FREE =>
            Probe.Data.Probe_Free (Event.Addr, Slot);

         when MAT.Events.Targets.MSG_REALLOC =>
            Probe.Data.Probe_Realloc (Event.Addr, Event.Old_Addr, Slot);

         when others =>
            raise Program_Error;

      end case;
   end Execute;

end MAT.Memory.Probes;

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

with MAT.Types;
with MAT.Readers.Marshaller;
with MAT.Memory;
package body MAT.Memory.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Probes");

   M_SIZE     : constant MAT.Events.Internal_Reference := 1;
   M_FRAME    : constant MAT.Events.Internal_Reference := 2;
   M_ADDR     : constant MAT.Events.Internal_Reference := 3;
   M_OLD_ADDR : constant MAT.Events.Internal_Reference := 4;
   M_THREAD   : constant MAT.Events.Internal_Reference := 5;
   M_UNKNOWN  : constant MAT.Events.Internal_Reference := 6;
   M_TIME     : constant MAT.Events.Internal_Reference := 7;
   --  Defines the possible data kinds which are recognized by
   --  the memory unmarshaller.  All others are ignored.

   SIZE_NAME  : aliased constant String := "size";
   FRAME_NAME : aliased constant String := "frame";
   ADDR_NAME  : aliased constant String := "pointer";
   OLD_NAME   : aliased constant String := "old-pointer";
   THREAD_NAME : aliased constant String := "thread";
   TIME_NAME   : aliased constant String := "time";

   Memory_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_SIZE),
      2 => (Name => FRAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FRAME),
      3 => (Name => ADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      4 => (Name => OLD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_OLD_ADDR),
      5 => (Name => THREAD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_THREAD, Ref => M_THREAD),
      6 => (Name => TIME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_TIME, Ref => M_TIME));

   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table);

   ----------------------
   --  Register the reader to extract and analyze memory events.
   ----------------------
   procedure Register (Into  : in out MAT.Events.Probes.Probe_Manager_Type'Class;
                       Probe : in Memory_Probe_Type_Access) is
   begin
      Into.Register_Probe (Probe.all'Access, "malloc", MAT.Events.Targets.MSG_MALLOC,
                           Memory_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "free", MAT.Events.Targets.MSG_FREE,
                           Memory_Attributes'Access);
      Into.Register_Probe (Probe.all'Access, "realloc", MAT.Events.Targets.MSG_REALLOC,
                           Memory_Attributes'Access);
   end Register;

   ----------------------
   --  Unmarshall from the message the memory slot information.
   --  The data is described by the Defs table.
   ----------------------
   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message_Type;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table) is
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_SIZE =>
                  Size := MAT.Readers.Marshaller.Get_Target_Size (Msg, Def.Kind);

               when M_ADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_OLD_ADDR =>
                  Old_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when M_UNKNOWN =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg, Def.Size);

            end case;
         end;
      end loop;
   end Unmarshall_Allocation;

   ----------------------
   --  Extract the probe information from the message.
   ----------------------
   overriding
   procedure Extract (Probe   : in Memory_Probe_Type;
                      Params  : in MAT.Events.Const_Attribute_Table_Access;
                      Msg     : in out MAT.Readers.Message_Type;
                      Event   : in out MAT.Events.Targets.Probe_Event_Type) is
   begin
      case Event.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MAT.Events.Targets.MSG_FREE =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MAT.Events.Targets.MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when others =>
            Log.Error ("Invalid event {0} for memory extract probe",
                       MAT.Events.Targets.Probe_Index_Type'Image (Event.Index));
            raise Program_Error;

      end case;
   end Extract;

   procedure Execute (Probe : in Memory_Probe_Type;
                      Event : in MAT.Events.Targets.Probe_Event_Type) is
      Slot     : Allocation;
   begin
      Slot.Size   := Event.Size;
      Slot.Thread := Event.Thread;
      Slot.Time   := Event.Time;
      Slot.Frame  := Event.Frame;
      case Event.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            Probe.Data.Probe_Malloc (Event.Addr, Slot);

         when MAT.Events.Targets.MSG_FREE =>
            Probe.Data.Probe_Free (Event.Addr, Slot);

         when MAT.Events.Targets.MSG_REALLOC =>
            Probe.Data.Probe_Realloc (Event.Addr, Event.Old_Addr, Slot);

         when others =>
            Log.Error ("Invalid event {0} for memory execute probe",
                       MAT.Events.Targets.Probe_Index_Type'Image (Event.Index));
            raise Program_Error;

      end case;
   end Execute;

end MAT.Memory.Probes;

Add some log when an event is not recognized


-----------------------------------------------------------------------
--  ADO Databases -- Database Objects
--  Copyright (C) 2009, 2010, 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 Ada.Strings.Unbounded;
with Ada.Calendar;
package ADO is

   type Int64 is range -2**63 .. 2**63 - 1;
   for Int64'Size use 64;

   type Unsigned64 is mod 2**64;
   for Unsigned64'Size use 64;

   --  ------------------------------
   --  Database Identifier
   --  ------------------------------
   --
   type Identifier is new Integer;

   NO_IDENTIFIER : constant Identifier := -1;

   type Entity_Type is new Integer;

   --  ------------------------------
   --  Nullable Types
   --  ------------------------------
   --  Most database allow to store a NULL instead of an actual integer, date or string value.
   --  Unlike Java, there is no easy way to distinguish between a NULL and an actual valid value.
   --  The <b>Nullable_T</b> types provide a way to specify and check whether a value is null
   --  or not.

   --  An integer which can be null.
   type Nullable_Integer is record
      Value   : Integer := 0;
      Is_Null : Boolean := True;
   end record;

   --  A string which can be null.
   type Nullable_String is record
      Value   : Ada.Strings.Unbounded.Unbounded_String;
      Is_Null : Boolean := True;
   end record;

   --  A date which can be null.
   type Nullable_Time is record
      Value   : Ada.Calendar.Time;
      Is_Null : Boolean := True;
   end record;

end ADO;

-----------------------------------------------------------------------
--  ADO Databases -- Database Objects
--  Copyright (C) 2009, 2010, 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 Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Refs;
with Util.Streams.Buffered;
package ADO is

   type Int64 is range -2**63 .. 2**63 - 1;
   for Int64'Size use 64;

   type Unsigned64 is mod 2**64;
   for Unsigned64'Size use 64;

   --  ------------------------------
   --  Database Identifier
   --  ------------------------------
   --
   type Identifier is range -2**47 .. 2**47 - 1;

   NO_IDENTIFIER : constant Identifier := -1;

   type Entity_Type is range 0 .. 2**16 - 1;

   NO_ENTITY_TYPE : constant Entity_Type := 0;

   type Object_Id is record
      Id   : Identifier;
      Kind : Entity_Type;
   end record;
   pragma Pack (Object_Id);

   --  ------------------------------
   --  Nullable Types
   --  ------------------------------
   --  Most database allow to store a NULL instead of an actual integer, date or string value.
   --  Unlike Java, there is no easy way to distinguish between a NULL and an actual valid value.
   --  The Nullable_T types provide a way to specify and check whether a value is null
   --  or not.

   --  An integer which can be null.
   type Nullable_Integer is record
      Value   : Integer := 0;
      Is_Null : Boolean := True;
   end record;

   --  A string which can be null.
   type Nullable_String is record
      Value   : Ada.Strings.Unbounded.Unbounded_String;
      Is_Null : Boolean := True;
   end record;

   --  A date which can be null.
   type Nullable_Time is record
      Value   : Ada.Calendar.Time;
      Is_Null : Boolean := True;
   end record;

   --  ------------------------------
   --  Blob data type
   --  ------------------------------
   --  The Blob type is used to represent database blobs.  The data is stored
   --  in an Ada.Streams.Stream_Element_Array pointed to by the Data member.
   --  The query statement and bind parameter will use a Blob_Ref which represents
   --  a reference to the blob data.  This is intended to minimize data copy.
   type Blob is new Util.Refs.Ref_Entity with record
      Data : Util.Streams.Buffered.Buffer_Access := null;
   end record;
   type Blob_Access is access all Blob;

   package Blob_References is new Util.Refs.References (Blob, Blob_Access);
   subtype Blob_Ref is Blob_References.Ref;

end ADO;

Define the Object_Id and Blob types

Define the Object_Id and Blob types


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

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String is
      use type Interfaces.Unsigned_64;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint64 := Value;
      N : Uint64;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Format the target time to a printable representation.
   --  ------------------------------
   function Tick_Image (Value : in Target_Tick_Ref) return String is
      use Interfaces;

      Sec  : constant Unsigned_32 := Unsigned_32 (Interfaces.Shift_Right (Uint64 (Value), 32));
      Usec : constant Unsigned_32 := Interfaces.Unsigned_32 (Value and 16#0ffffffff#);
      Frac : constant String := Interfaces.Unsigned_32'Image (Usec);
      Img  : String (1 .. 6) := (others => '0');
   begin
      Img (Img'Last - Frac'Length + 2 .. Img'Last) := Frac (Frac'First + 1 .. Frac'Last);
      return Interfaces.Unsigned_32'Image (Sec) & "." & Img;
   end Tick_Image;

   --  ------------------------------
   --  Convert the hexadecimal string into an unsigned integer.
   --  ------------------------------
   function Hex_Value (Value : in String) return Uint64 is
      use type Interfaces.Unsigned_64;

      Result : Uint64 := 0;
   begin
      if Value'Length = 0 then
         raise Constraint_Error with "Empty string";
      end if;
      for I in Value'Range loop
         declare
            C : constant Character := Value (I);
         begin
            if C >= '0' and C <= '9' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('0'));
            elsif C >= 'A' and C <= 'F' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('A') + 10);
            elsif C >= 'a' and C <= 'f' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('a') + 10);
            else
               raise Constraint_Error with "Invalid character: " & C;
            end if;
         end;
      end loop;
      return Result;
   end Hex_Value;

end MAT.Types;

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

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String is
      use type Interfaces.Unsigned_64;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint64 := Value;
      N : Uint64;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Format the target time to a printable representation.
   --  ------------------------------
   function Tick_Image (Value : in Target_Tick_Ref) return String is
      use Interfaces;

      Sec  : constant Unsigned_32 := Unsigned_32 (Interfaces.Shift_Right (Uint64 (Value), 32));
      Usec : constant Unsigned_32 := Interfaces.Unsigned_32 (Value and 16#0ffffffff#);
      Frac : constant String := Interfaces.Unsigned_32'Image (Usec);
      Img  : String (1 .. 6) := (others => '0');
   begin
      Img (Img'Last - Frac'Length + 2 .. Img'Last) := Frac (Frac'First + 1 .. Frac'Last);
      return Interfaces.Unsigned_32'Image (Sec) & "." & Img;
   end Tick_Image;

   --  ------------------------------
   --  Convert the string in the form NN.MM into a tick value.
   --  ------------------------------
   function Tick_Value (Value : in String) return Target_Tick_Ref is
      use Interfaces;

      Pos  : Natural := Util.Strings.Index (Value, '.');
      Frac : Uint64;
      Val  : Uint64;
   begin
      if Pos > 0 then
         Frac := Uint64'Value (Value (Pos + 1 .. Value'Last));
         for I in 1 .. 6 - (Value'Last - Pos) loop
            Frac := Frac * 10;
         end loop;
         if Pos > Value'First then
            Val := Uint64'Value (Value (Value'First .. Pos - 1));
         else
            Val := 0;
         end if;
      else
         Frac := 0;
         Val := Uint64'Value (Value);
      end if;
      return Target_Tick_Ref (Val * 1_000_000 + Frac);
   end Tick_Value;

   --  ------------------------------
   --  Convert the hexadecimal string into an unsigned integer.
   --  ------------------------------
   function Hex_Value (Value : in String) return Uint64 is
      use type Interfaces.Unsigned_64;

      Result : Uint64 := 0;
   begin
      if Value'Length = 0 then
         raise Constraint_Error with "Empty string";
      end if;
      for I in Value'Range loop
         declare
            C : constant Character := Value (I);
         begin
            if C >= '0' and C <= '9' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('0'));
            elsif C >= 'A' and C <= 'F' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('A') + 10);
            elsif C >= 'a' and C <= 'f' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('a') + 10);
            else
               raise Constraint_Error with "Invalid character: " & C;
            end if;
         end;
      end loop;
      return Result;
   end Hex_Value;

end MAT.Types;

Implement Tick_Value to convert a string into a time


-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  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 Util.Log.Loggers;

with MAT.Types;
with MAT.Readers.Marshaller;
with MAT.Memory;
package body MAT.Memory.Readers is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Readers");

   MSG_MALLOC  : constant MAT.Events.Internal_Reference := 0;
   MSG_FREE    : constant MAT.Events.Internal_Reference := 1;
   MSG_REALLOC : constant MAT.Events.Internal_Reference := 2;

   M_SIZE     : constant MAT.Events.Internal_Reference := 1;
   M_FRAME    : constant MAT.Events.Internal_Reference := 2;
   M_ADDR     : constant MAT.Events.Internal_Reference := 3;
   M_OLD_ADDR : constant MAT.Events.Internal_Reference := 4;
   M_THREAD   : constant MAT.Events.Internal_Reference := 5;
   M_UNKNOWN  : constant MAT.Events.Internal_Reference := 6;
   M_TIME     : constant MAT.Events.Internal_Reference := 7;
   --  Defines the possible data kinds which are recognized by
   --  the memory unmarshaller.  All others are ignored.

   SIZE_NAME  : aliased constant String := "size";
   FRAME_NAME : aliased constant String := "frame";
   ADDR_NAME  : aliased constant String := "pointer";
   OLD_NAME   : aliased constant String := "old-pointer";
   THREAD_NAME : aliased constant String := "thread";
   TIME_NAME   : aliased constant String := "time";

   Memory_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_SIZE),
      2 => (Name => FRAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FRAME),
      3 => (Name => ADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      4 => (Name => OLD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_OLD_ADDR),
      5 => (Name => THREAD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_THREAD, Ref => M_THREAD),
      6 => (Name => TIME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_TIME, Ref => M_TIME));

   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Slot     : in out Allocation;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table);

   ----------------------
   --  Register the reader to extract and analyze memory events.
   ----------------------
   procedure Register (Into   : in out MAT.Readers.Manager_Base'Class;
                       Reader : in Memory_Reader_Access) is
   begin
      Into.Register_Reader (Reader.all'Access, "malloc", MSG_MALLOC,
                            Memory_Attributes'Access);
      Into.Register_Reader (Reader.all'Access, "free", MSG_FREE,
                            Memory_Attributes'Access);
      Into.Register_Reader (Reader.all'Access, "realloc", MSG_REALLOC,
                            Memory_Attributes'Access);
   end Register;

   ----------------------
   --  Unmarshall from the message the memory slot information.
   --  The data is described by the Defs table.
   ----------------------
   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Slot     : in out Allocation;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table) is
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_SIZE =>
                  Slot.Size := MAT.Readers.Marshaller.Get_Target_Size (Msg.Buffer, Def.Kind);

               when M_ADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_OLD_ADDR =>
                  Old_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_UNKNOWN =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);
            end case;
         end;
      end loop;
   end Unmarshall_Allocation;

   overriding
   procedure Dispatch (For_Servant : in out Memory_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out MAT.Readers.Message) is
      Slot     : Allocation;
      Addr     : MAT.Types.Target_Addr := 0;
      Old_Addr : MAT.Types.Target_Addr := 0;
   begin
      Slot.Thread := Frame.Thread;
      Slot.Time   := Frame.Time;
      case Id is
         when MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            For_Servant.Data.Create_Frame (Pc     => Frame.Frame (1 .. Frame.Cur_Depth),
                                           Result => Slot.Frame);
            For_Servant.Data.Probe_Malloc (Addr, Slot);

         when MSG_FREE =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            For_Servant.Data.Probe_Free (Addr, Slot);

         when MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Slot, Addr, Old_Addr, Params.all);
            For_Servant.Data.Create_Frame (Pc     => Frame.Frame (1 .. Frame.Cur_Depth),
                                           Result => Slot.Frame);
            For_Servant.Data.Probe_Realloc (Addr, Old_Addr, Slot);

         when others =>
            raise Program_Error;

      end case;
   end Dispatch;

end MAT.Memory.Readers;

-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  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 Util.Log.Loggers;

with MAT.Types;
with MAT.Readers.Marshaller;
with MAT.Memory;
package body MAT.Memory.Readers is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Memory.Readers");

   MSG_MALLOC  : constant MAT.Events.Internal_Reference := 0;
   MSG_FREE    : constant MAT.Events.Internal_Reference := 1;
   MSG_REALLOC : constant MAT.Events.Internal_Reference := 2;

   M_SIZE     : constant MAT.Events.Internal_Reference := 1;
   M_FRAME    : constant MAT.Events.Internal_Reference := 2;
   M_ADDR     : constant MAT.Events.Internal_Reference := 3;
   M_OLD_ADDR : constant MAT.Events.Internal_Reference := 4;
   M_THREAD   : constant MAT.Events.Internal_Reference := 5;
   M_UNKNOWN  : constant MAT.Events.Internal_Reference := 6;
   M_TIME     : constant MAT.Events.Internal_Reference := 7;
   --  Defines the possible data kinds which are recognized by
   --  the memory unmarshaller.  All others are ignored.

   SIZE_NAME  : aliased constant String := "size";
   FRAME_NAME : aliased constant String := "frame";
   ADDR_NAME  : aliased constant String := "pointer";
   OLD_NAME   : aliased constant String := "old-pointer";
   THREAD_NAME : aliased constant String := "thread";
   TIME_NAME   : aliased constant String := "time";

   Memory_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => SIZE_NAME'Access, Size => 0,
            Kind => MAT.Events.T_SIZE_T, Ref => M_SIZE),
      2 => (Name => FRAME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_FRAME, Ref => M_FRAME),
      3 => (Name => ADDR_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_ADDR),
      4 => (Name => OLD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_POINTER, Ref => M_OLD_ADDR),
      5 => (Name => THREAD_NAME'Access, Size => 0,
            Kind => MAT.Events.T_THREAD, Ref => M_THREAD),
      6 => (Name => TIME_NAME'Access, Size => 0,
            Kind => MAT.Events.T_TIME, Ref => M_TIME));

   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table);

   ----------------------
   --  Register the reader to extract and analyze memory events.
   ----------------------
   procedure Register (Into   : in out MAT.Readers.Manager_Base'Class;
                       Reader : in Memory_Reader_Access) is
   begin
      Into.Register_Reader (Reader.all'Access, "malloc", MSG_MALLOC,
                            Memory_Attributes'Access);
      Into.Register_Reader (Reader.all'Access, "free", MSG_FREE,
                            Memory_Attributes'Access);
      Into.Register_Reader (Reader.all'Access, "realloc", MSG_REALLOC,
                            Memory_Attributes'Access);
   end Register;

   ----------------------
   --  Unmarshall from the message the memory slot information.
   --  The data is described by the Defs table.
   ----------------------
   procedure Unmarshall_Allocation (Msg      : in out MAT.Readers.Message;
                                    Size     : in out MAT.Types.Target_Size;
                                    Addr     : in out MAT.Types.Target_Addr;
                                    Old_Addr : in out MAT.Types.Target_Addr;
                                    Defs     : in MAT.Events.Attribute_Table) is
   begin
      for I in Defs'Range loop
         declare
            Def : MAT.Events.Attribute renames Defs (I);
         begin
            case Def.Ref is
               when M_SIZE =>
                  Size := MAT.Readers.Marshaller.Get_Target_Size (Msg.Buffer, Def.Kind);

               when M_ADDR =>
                  Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_OLD_ADDR =>
                  Old_Addr := MAT.Readers.Marshaller.Get_Target_Addr (Msg.Buffer, Def.Kind);

               when M_UNKNOWN =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);

               when others =>
                  MAT.Readers.Marshaller.Skip (Msg.Buffer, Def.Size);
            end case;
         end;
      end loop;
   end Unmarshall_Allocation;

   overriding
   procedure Extract (For_Servant : in out Memory_Servant;
                      Event       : in out MAT.Events.Targets.Target_Event;
                      Id          : in MAT.Events.Internal_Reference;
                      Params      : in MAT.Events.Const_Attribute_Table_Access;
                      Msg         : in out MAT.Readers.Message) is
   begin
      case Id is
         when MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MSG_FREE =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Event.Size, Event.Addr, Event.Old_Addr, Params.all);

         when others =>
            raise Program_Error;

      end case;
   end Extract;

   overriding
   procedure Dispatch (For_Servant : in out Memory_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out MAT.Readers.Message) is
      Slot     : Allocation;
      Addr     : MAT.Types.Target_Addr := 0;
      Old_Addr : MAT.Types.Target_Addr := 0;
   begin
      Slot.Thread := Frame.Thread;
      Slot.Time   := Frame.Time;
      case Id is
         when MSG_MALLOC =>
            Unmarshall_Allocation (Msg, Slot.Size, Addr, Old_Addr, Params.all);
            For_Servant.Data.Create_Frame (Pc     => Frame.Frame (1 .. Frame.Cur_Depth),
                                           Result => Slot.Frame);
            For_Servant.Data.Probe_Malloc (Addr, Slot);

         when MSG_FREE =>
            Unmarshall_Allocation (Msg, Slot.Size, Addr, Old_Addr, Params.all);
            For_Servant.Data.Probe_Free (Addr, Slot);

         when MSG_REALLOC =>
            Unmarshall_Allocation (Msg, Slot.Size, Addr, Old_Addr, Params.all);
            For_Servant.Data.Create_Frame (Pc     => Frame.Frame (1 .. Frame.Cur_Depth),
                                           Result => Slot.Frame);
            For_Servant.Data.Probe_Realloc (Addr, Old_Addr, Slot);

         when others =>
            raise Program_Error;

      end case;
   end Dispatch;

end MAT.Memory.Readers;

Implement the Extract procedure

Implement the Extract procedure