------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A 4 G . N O R M                              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2006, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines routines needed for yielding and processing
--  normalized associations and their components

with Asis;

with Types; use Types;

package A4G.Norm is

   ---------------------------------------
   -- Obtaining normalized associations --
   ---------------------------------------

   function Normalized_Param_Associations
     (Call_Elem : Asis.Element)
      return      Asis.Association_List;
   --  Creates the list of normalized associations for a given call to an
   --  entry, a procedure or to a function (is intended to be used in the
   --  implementation of Asis.Expressions.Function_Call_Parameters and
   --  Asis.Statements.Call_Statement_Parameters). This function assumes that
   --  the association list to be returned is not empty. It is an error to call
   --  it when Sinfo.Parameter_Assoccciations function gives No_List for
   --  the node representing the call in question

   function Normalized_Discriminant_Associations
     (Constr_Elem : Asis.Element;
      Constr_Node : Node_Id)
      return Asis.Association_List;
   --  creates the list of normalized associations for a given discriminant
   --  constraint; is intended to be used in the implementation of
   --  Asis.Definitions.Discriminant_Associations. This function assumes,
   --  that Constr_Node is of N_Index_Or_Discriminant_Constraint,
   --  it is an error to call it for other nodes.

   function Normalized_Generic_Associations
     (Inst_Elem          : Asis.Element;
      Templ_Node         : Node_Id)
      return Asis.Association_List;
   --  Creates the list of normalized associations for a given generic
   --  instantiation (is intended to be used in the implementation of
   --  Asis.Decalarations.Generic_Actual_Part. Templ_Node should be the
   --  node representing the corresponding generic template declaration.
   --  This function is supposed to be called if it is known that the list
   --  of normalized associations is not empty
   --
   --  See the documentation of the body for the description of the
   --  representation of the normalized generic associations.

   function Normalized_Record_Component_Associations
     (Aggregate : Asis.Element)
      return      Asis.Element_List;
   --  Creates a list of normalized associations for a record aggregate

   function Defining_Gen_Parameter (Gen_Form_Par : Node_Id) return Node_Id;
   --  Assuming that Gen_Form_Par is a node representing a
   --  generic_formal_parameter_SELECTOR_NAME (it is an error to call this
   --  function for another actual!!!), this function finds the node
   --  representing the defining occurrence of this generic formal
   --  parameter.
   --
   --  ??? Is here a really good place for this function?
   --
   --  ???  And do we really need it???
   --
   --  For now this function is PARTIALLY IMPLEMENTED - it can work only
   --  with a generic_formal_parameter_SELECTOR_NAME which is
   --  operator_symbol "+" or "-"

   ----------------------------------------
   -- Processing normalized associations --
   ----------------------------------------

   function Discr_Def_Name
     (Association : Asis.Discriminant_Association)
      return        Asis.Defining_Name;
   --  from a normalized discriminant association  this function creates
   --  the ASIS Element representing the defining occurrence of the
   --  discriminant. (Is intended to be used in
   --  Asis.Expressions.Discriminant_Selector_Names).
   --
   --  !!!NOTE: for now the implementation is unstable and definitely
   --           contains holes.
end A4G.Norm;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  Util.Concurrent -- Concurrent Counters
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

--  The Counters package defines the Counter type which provides
--  atomic increment and decrement operations.  It is intended to be used to
--  implement reference counting in a multi-threaded environment.
--
--    type Ref is record
--        Cnt  : Counter;
--        Data : ...;
--    end record;
--
--    Object  : access Ref;
--    Is_Last : Boolean;
--  begin
--    Decrement (Object.Cnt, Is_Last);  -- Multi-task safe operation
--    if Is_Last then
--        Free (Object);
--    end if;
--
--  Unlike the Ada portable implementation based on protected type, this implementation
--  does not require that Counter be a limited type.
private with Interfaces;
package Util.Concurrent.Counters is

   pragma Preelaborate;

   --  ------------------------------
   --  Atomic Counter
   --  ------------------------------
   --  The atomic Counter implements a simple counter that can be
   --  incremented or decremented atomically.
   type Counter is private;
   type Counter_Access is access all Counter;

   --  Increment the counter atomically.
   procedure Increment (C : in out Counter);
   pragma Inline_Always (Increment);

   --  Increment the counter atomically and return the value before increment.
   procedure Increment (C     : in out Counter;
                        Value : out Integer);
   pragma Inline_Always (Increment);

   --  Decrement the counter atomically.
   procedure Decrement (C : in out Counter);
   pragma Inline_Always (Decrement);

   --  Decrement the counter atomically and return a status.
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean);
   pragma Inline_Always (Decrement);

   --  Get the counter value
   function Value (C : in Counter) return Integer;
   pragma Inline_Always (Value);

   ONE : constant Counter;

private

   --  This implementation works without an Ada protected type:
   --  o The size of the target object is 10 times smaller.
   --  o Increment and Decrement operations are 5 times faster.
   --  o It works by using special instructions
   --  o The counter is Atomic to make sure the compiler will use atomic read/write instructions
   --    and it prevents optimization (Atomic implies Volatile).  The Atomic does not mean
   --    that atomic instructions are used.
   type Counter is record
      Value : aliased Interfaces.Unsigned_32 := 0;
      pragma Atomic (Value);
   end record;

   ONE : constant Counter := Counter '(Value => 1);

end Util.Concurrent.Counters;

Declare the Counters package for the gcc builtin implementation


------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--                A S I S . A D A _ E N V I R O N M E N T S                 --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                                                                          --
--           Copyright (c) 2006, Free Software Foundation, Inc.             --
--                                                                          --
-- This   specification  is  adapted   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  In accordance --
-- with the copyright of that document, you can freely copy and modify this --
-- specification, provided that if you redistribute a modified version, any --
-- changes  that  you have made are clearly indicated. The copyright notice --
-- above,  and  the  license  provisions  that  follow  apply solely to the --
-- contents of the part following the private keyword.                      --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR  PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with ASIS-for-GNAT;  see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  8  package Asis.Ada_Environments
------------------------------------------------------------------------------
------------------------------------------------------------------------------
package Asis.Ada_Environments is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Ada_Environments encapsulates a set of queries that map physical Ada
--  compilation and program execution environments to logical ASIS
--  environments.
--
------------------------------------------------------------------------------
--  8.1   function Default_Name
------------------------------------------------------------------------------

   function Default_Name return Wide_String;

------------------------------------------------------------------------------
--  Returns the default context name.  If there is no default context name, a
--  null string is returned.
--
------------------------------------------------------------------------------
--  8.2   function Default_Parameters
------------------------------------------------------------------------------

   function Default_Parameters return Wide_String;

------------------------------------------------------------------------------
--  Returns the default context parameters.  If there are no default context
--  parameters, a null string is returned.
--
------------------------------------------------------------------------------
--  8.3   procedure Associate
------------------------------------------------------------------------------

   procedure Associate
     (The_Context : in out Asis.Context;
      Name        :        Wide_String;
      Parameters  :        Wide_String := Default_Parameters);

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to associate
--  Name        - Specifies the name for the Context association
--  Parameters  - Specifies parameters to use when opening the Context
--
--  Used to give name and parameter associations to a Context.  The
--  Has_Associations query is used to test whether or not a Context has
--  been given name and parameter associations.  The Name and Parameters
--  queries are used to examine name and parameter associations.
--
--  A Context has at most one set of name/parameter values associated with
--  it at any time.  Name and parameter associations cannot be modified while a
--  Context is open  Previous name and parameters associations for this Context
--  are replaced by this call.
--
--  ASIS implementations are encouraged, but not required, to validate the
--  Parameters string immediately.  It is recognized that some options cannot
--  be completely validated until the Open is performed.  An invalid Parameters
--  value is reported by raising ASIS_Failed with a Status of Parameter_Error.
--
--  Raises ASIS_Inappropriate_Context if The_Context is open.
--
------------------------------------------------------------------------------
--  8.4   procedure Open
------------------------------------------------------------------------------

   procedure Open (The_Context : in out Asis.Context);

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to open
--
--  Opens the ASIS Context using the Context's associated name and parameter
--  values.
--
--  Raises ASIS_Inappropriate_Context if The_Context is already open or if it
--  is uninitialized (does not have associated name and parameter values).
--
--  Raises ASIS_Failed if The_Context could not be opened for any reason.  The
--  most likely Status values are Name_Error, Use_Error, Data_Error, and
--  Parameter_Error.  Other possibilities include Storage_Error and
--  Capacity_Error.
--
------------------------------------------------------------------------------
--  8.5   procedure Close
------------------------------------------------------------------------------

   procedure Close (The_Context : in out Asis.Context);

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to close
--
--  Closes the ASIS Context.  Any previous Context name and parameter
--  associations are retained.  This allows the same Context to be re-opened
--  later with the same associations.
--
--  All Compilation_Unit and Element values obtained from The_Context become
--  invalid when it is closed.  Subsequent calls to ASIS services using such
--  invalid Compilation_Unit or Element values are erroneous.  ASIS
--  implementations will attempt to detect such usage and raise ASIS_Failed in
--  response.  Applications should be aware that the ability to detect the use
--  of such "dangling references" is implementation specific and not all
--  implementations are able to raise ASIS_Failed at the appropriate
--  points.  Thus, applications that attempt to utilize invalid values may
--  exhibit unpredictable behavior.
--
--  Raises ASIS_Inappropriate_Context if The_Context is not open.
--
------------------------------------------------------------------------------
--  8.6   procedure Dissociate
------------------------------------------------------------------------------

   procedure Dissociate (The_Context : in out Asis.Context);

------------------------------------------------------------------------------
--  The_Context - Specifies the Context whose name and parameter associations
--                are to be cleared
--
--  Severs all previous associations for The_Context.  A Context that does not
--  have associations (is uninitialized) is returned unchanged.  The
--  variable The_Context is returned to its uninitialized state.
--
--  Contexts that have been given Names and Parameters should be Dissociated
--  when they are no longer necessary.  Some amount of program storage can be
--  tied up by the stored Name and Parameter strings.  This space is only
--  freed when a Context is Dissociated or when ASIS is Finalized.
--
--  This operation has no physical affect on any implementor's Ada environment.
--
--  Raises ASIS_Inappropriate_Context if The_Context is open.
--
------------------------------------------------------------------------------
--  8.7   function Is_Equal
------------------------------------------------------------------------------

   function Is_Equal
     (Left  :  Asis.Context;
      Right :  Asis.Context)
      return   Boolean;

------------------------------------------------------------------------------
--  Left    - Specifies the first Context
--  Right   - Specifies the second Context
--
--  Returns True if Left and Right designate the same set of associated
--  compilation units.  The Context variables may be open or closed.
--
--  Unless both Contexts are open, this operation is implemented as a pair of
--  simple string comparisons between the Name and Parameter associations for
--  the two Contexts.  If both Contexts are open, this operation acts as a
--  set comparison and returns True if both sets contain the same units (all
--  unit versions are included in the comparison).
--
--  --|AN Application Note:
--  --|AN
--  --|AN With some implementations, Is_Equal may be True before the Contexts
--  --|AN are opened, but may be False after the Contexts are open.
--  --|AN One possible cause for this is a sequence of events such as:
--  --|AN
--  --|AN  1) ASIS program A opens the Left Context for READ,
--  --|AN  2) non-ASIS program B opens the Context for UPDATE, and creates
--  --|AN     a new version of the implementor Context,
--  --|AN  3) ASIS program A opens the Right Context for READ, and gets the
--  --|AN     new version.
--
------------------------------------------------------------------------------
--  8.8   function Is_Identical
------------------------------------------------------------------------------

   function Is_Identical
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean;

------------------------------------------------------------------------------
--  Left    - Specifies the first Context
--  Right   - Specifies the second Context
--
--  Returns True if Left and Right both designate the value associated with
--  one specific ASIS Context variable.
--
--  Returns False otherwise or if either Context is not open.
--
--  --|AN Application Note:
--  --|AN
--  --|AN No two physically separate open Context variables are ever
--  --|AN Is_Identical. The value associated with an open ASIS Context variable
--  --|AN is also directly associated with every Compilation_Unit or Element
--  --|AN derived from that Context. It is possible to obtain these Context
--  --|AN values by way of the Enclosing_Context and the
--  --|AN Enclosing_Compilation_Unit queries. These Context values can be
--  --|AN tested for identity with each other or with specific Context
--  --|AN variables.  An open ASIS Context variable and an Enclosing_Context
--  --|AN value are only Is_Identical if the Compilation_Unit in question
--  --|AN was derived specifically from that open ASIS Context variable.
--
------------------------------------------------------------------------------
--  8.9   function Exists
------------------------------------------------------------------------------

   function Exists (The_Context : Asis.Context) return Boolean;

------------------------------------------------------------------------------
--  The_Context - Specifies a Context with associated name and parameter values
--
--  Returns True if The_Context is open or if The_Context designates an Ada
--  environment that can be determined to exist.
--
--  Returns False for any uninitialized The_Context variable.
--
--  --|IP Implementation Permissions:
--  --|IP
--  --|IP No guarantee is made that The_Context is readable or that an Open
--  --|IP operation on The_Context would succeed.  The associated
--  --|IP parameter value for The_Context may not be fully validated by this
--  --|IP simple existence check.  It may contain information that can only be
--  --|IP verified by an Open.
--
------------------------------------------------------------------------------
--  8.10  function Is_Open
------------------------------------------------------------------------------

   function Is_Open (The_Context : Asis.Context) return Boolean;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to check
--
--  Returns True if The_Context is currently open.
--
------------------------------------------------------------------------------
--  8.11  function Has_Associations
------------------------------------------------------------------------------

   function Has_Associations (The_Context : Asis.Context) return Boolean;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to check
--
--  Returns True if name and parameter values have been associated with
--  The_Context.
--
--  Returns False if The_Context is uninitialized.
--
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  8.12  function Name
------------------------------------------------------------------------------

   function Name (The_Context : Asis.Context) return Wide_String;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to check
--
--  Returns the Name value associated with The_Context.
--
--  Returns a null string if The_Context is uninitialized.
--
------------------------------------------------------------------------------
--  8.13  function Parameter
------------------------------------------------------------------------------

   function Parameters (The_Context : Asis.Context) return Wide_String;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to check
--
--  Returns the Parameters value associated with The_Context.
--
--  Returns a null string if The_Context is uninitialized.
--
------------------------------------------------------------------------------
--  8.14  function Debug_Image
------------------------------------------------------------------------------

   function Debug_Image (The_Context : Asis.Context) return Wide_String;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to represent
--
--  Returns a string value containing implementation-defined debugging
--  information associated with The_Context.
--
--  The return value uses Asis.Text.Delimiter_Image to separate lines in
--  multi-line results.  The return value is not terminated with
--  Asis.Text.Delimiter_Image.
--
--  Returns a null string if The_Context is uninitialized.
--
--  These values are intended for two purposes.  They are suitable for
--  inclusion in problem reports sent to the ASIS implementor.  They can be
--  presumed to contain information useful when debugging the implementation
--  itself. They are also suitable for use by the ASIS application when
--  printing simple application debugging messages during application
--  development. They are intended to be, to some worthwhile degree,
--  intelligible to the user.

end Asis.Ada_Environments;

Add the ASIS file $i

Add the ASIS file $i


{header}
--  The MIT License (MIT)

--  Copyright (c) 2015 Pavel Zhukov <landgraf@fedoraproject.org>

--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:

--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.

--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.

package Nanomsg.Bus is
   Nn_Proto_Bus : constant := 7;
   Nn_Bus : constant Protocol_T := Nn_Proto_Bus * 16 + 0;и
end Nanomsg.Bus;

Add Readme

Add Readme


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

with Ada.Unchecked_Deallocation;
with Interfaces.C.Strings;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

   --  ------------------------------
   --  Wait for the process to exit.
   --  ------------------------------
   overriding
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is
      pragma Unreferenced (Sys, Timeout);

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

   --  ------------------------------
   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   --  ------------------------------
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is
      pragma Unreferenced (Sys);
      Result : Integer;
   begin
      Result := Sys_Kill (Integer (Proc.Pid), Integer (Signal));
   end Stop;

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Util.Streams.Raw;
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;
      pragma Unreferenced (Result);

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.
         if Mode = READ_ALL or Mode = READ_WRITE_ALL then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         if Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));

         elsif Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
               Result := Sys_Close (Stdout_Pipes (1));
            end if;
            Result := Sys_Close (Stdout_Pipes (0));

         elsif Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
               Result := Sys_Close (Stdin_Pipes (0));
            end if;
            Result := Sys_Close (Stdin_Pipes (1));

         elsif Sys.In_File /= Null_Ptr then
            --  Redirect the process input to a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.Out_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDIN_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean) is
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
   end Finalize;

end Util.Processes.Os;

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

with Ada.Unchecked_Deallocation;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

   --  ------------------------------
   --  Wait for the process to exit.
   --  ------------------------------
   overriding
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration) is
      pragma Unreferenced (Sys, Timeout);

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

   --  ------------------------------
   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   --  ------------------------------
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15) is
      pragma Unreferenced (Sys);
      Result : Integer;
   begin
      Result := Sys_Kill (Integer (Proc.Pid), Integer (Signal));
   end Stop;

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Util.Streams.Raw;
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;
      pragma Unreferenced (Result);

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.
         if Mode = READ_ALL or Mode = READ_WRITE_ALL then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         if Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));

         elsif Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
               Result := Sys_Close (Stdout_Pipes (1));
            end if;
            Result := Sys_Close (Stdout_Pipes (0));

         elsif Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDOUT_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         if Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
               Result := Sys_Close (Stdin_Pipes (0));
            end if;
            Result := Sys_Close (Stdin_Pipes (1));

         elsif Sys.In_File /= Null_Ptr then
            --  Redirect the process input to a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.Out_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               Result := Sys_Dup2 (Fd, STDIN_FILENO);
               Result := Sys_Close (Fd);
            end;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean) is
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
   end Finalize;

end Util.Processes.Os;

Remove unecessary with clause

Remove unecessary with clause


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

with ADO.Schemas;
with ADO.Statements;

package body ADO.Datasets is

   --  ------------------------------
   --  Execute the SQL query on the database session and populate the dataset.
   --  The column names are used to setup the dataset row bean definition.
   --  ------------------------------
   procedure List (Into    : in out Dataset;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.Queries.Context'Class) is
      procedure Fill (Data : in out Util.Beans.Objects.Datasets.Object_Array);

      Stmt : ADO.Statements.Query_Statement := Session.Create_Statement (Query);

      procedure Fill (Data : in out Util.Beans.Objects.Datasets.Object_Array) is
         use ADO.Schemas;
      begin
         for I in Data'Range loop
            case Stmt.Get_Column_Type (I - 1) is
               --  Boolean column
               when T_BOOLEAN =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_Boolean (I - 1));

               when T_TINYINT | T_SMALLINT | T_INTEGER | T_LONG_INTEGER | T_YEAR =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_Integer (I - 1));

               when T_FLOAT | T_DOUBLE | T_DECIMAL =>
                  Data (I) := Util.Beans.Objects.Null_Object;

               when T_ENUM =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_String (I - 1));

               when T_TIME | T_DATE | T_DATE_TIME | T_TIMESTAMP =>
                  Data (I) := Util.Beans.Objects.Time.To_Object (Stmt.Get_Time (I - 1));

               when T_CHAR | T_VARCHAR =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_String (I - 1));

               when T_BLOB =>
                  Data (I) := Util.Beans.Objects.Null_Object;

               when T_SET | T_UNKNOWN | T_NULL =>
                  Data (I) := Util.Beans.Objects.Null_Object;

            end case;
         end loop;
      end Fill;

   begin
      Stmt.Execute;
      Into.Clear;
      if Stmt.Has_Elements then
         for I in 1 .. Stmt.Get_Column_Count loop
            Into.Add_Column (Stmt.Get_Column_Name (I - 1));
         end loop;
         while Stmt.Has_Elements loop
            Into.Append (Fill'Access);
            Stmt.Next;
         end loop;
      end if;
   end List;

end ADO.Datasets;

Implement the List operation to setup the database with the SQL query result


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

with Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   --  ------------------------------
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

   --  ------------------------------
   --  Set the XHTML reader to ignore empty lines.
   --  ------------------------------
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean) is
   begin
      Reader.Ignore_Empty_Lines := Value;
   end Set_Ignore_Empty_Lines;

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

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

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input'Class);

      procedure Fill (From : in out Stream_Input'Class) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   --  ------------------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  Write a XML name/value entity (see Write_Attribute).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

   --  ------------------------------
   --  Starts a XML array.
   --  ------------------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
   begin
      null;
   end Start_Array;

   --  ------------------------------
   --  Terminates a XML array.
   --  ------------------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      null;
   end End_Array;

end Util.Serialize.IO.XML;

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

with Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   --  ------------------------------
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

   --  ------------------------------
   --  Set the XHTML reader to ignore empty lines.
   --  ------------------------------
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean) is
   begin
      Reader.Ignore_Empty_Lines := Value;
   end Set_Ignore_Empty_Lines;

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

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

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input'Class);

      procedure Fill (From : in out Stream_Input'Class) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   --  ------------------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  Write a XML name/value entity (see Write_Attribute).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

   --  ------------------------------
   --  Starts a XML array.
   --  ------------------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
   begin
      null;
   end Start_Array;

   --  ------------------------------
   --  Terminates a XML array.
   --  ------------------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      null;
   end End_Array;

end Util.Serialize.IO.XML;

Use Stream.Write instead of Stream.Write_String to write the attribute value (otherwise we can close the current entity by writing the '>')


-----------------------------------------------------------------------
--  AUnit utils - Helper for writing unit tests
--  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.
-----------------------------------------------------------------------

package body Util.Test_Caller is

   procedure Add_Test (Suite     : in Util.Tests.Access_Test_Suite;
                       Test_Name : in String;
                       Method    : in Caller.Test_Method) is
   begin
      Suite.Add_Test (Caller.Create (Test_Name, Method));
   end Add_Test;

end Util.Test_Caller;

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

package body Util.Test_Caller is

   procedure Add_Test (Suite     : in Util.Tests.Access_Test_Suite;
                       Test_Name : in String;
                       Method    : in Caller.Test_Method) is
   begin
      if Util.Tests.Is_Test_Enabled (Test_Name) then
         Suite.Add_Test (Caller.Create (Test_Name, Method));
      end if;
   end Add_Test;

end Util.Test_Caller;

Use the Is_Test_Enabled function to ignore or take into account the test when it is added in the testsuite.