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

--  == Introduction ==
--  The <b>Storages</b> module provides a set of storage services allowing an application
--  to store data files, documents, images in a persistent area.  The persistent store can
--  be on a file system, in the database or provided by a remote service such as
--  Amazon Simple Storage Service.
--
--  == Creating a storage ==
--  A content in the storage is represented by a `Storage_Ref` instance.  The data itself
--  can be physically stored in the file system (`FILE` mode), in the database (`DATABASE`
--  mode) or on a remote server (`URL` mode).  To put a file in the storage, first create
--  the storage object instance:
--
--    Data     : AWA.Storages.Models.Storage_Ref;
--
--  Then setup the storage mode that you want.  The storage service uses this information
--  to save the data in a file, in the database or in a remote service (in the future).
--
--    Data.Set_Storage (AWA.Storages.Models.DATABASE);
--
--  To save a file in the store, we can use the `Save` operation.  It will read the file
--  and put in in the corresponding persistent store (the database in this example).
--
--    Service.Save (Data, Path);
--
--  Upon successful completion, the storage instance `Data` will be allocated a unique
--  identifier that can be retrieved by `Get_Id` or `Get_Key`.
--
--  == Ada Beans ==
--  @include storages.xml
--
--  == Model ==
--  [http://ada-awa.googlecode.com/svn/wiki/awa_storage_model.png]
--
--  @include Storages.hbm.xml
package AWA.Storages is

end AWA.Storages;

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

--  == Introduction ==
--  The <b>Storages</b> module provides a set of storage services allowing an application
--  to store data files, documents, images in a persistent area.  The persistent store can
--  be on a file system, in the database or provided by a remote service such as
--  Amazon Simple Storage Service.
--
--  == Creating a storage ==
--  A content in the storage is represented by a `Storage_Ref` instance.  The data itself
--  can be physically stored in the file system (`FILE` mode), in the database (`DATABASE`
--  mode) or on a remote server (`URL` mode).  To put a file in the storage, first create
--  the storage object instance:
--
--    Data : AWA.Storages.Models.Storage_Ref;
--
--  Then setup the storage mode that you want.  The storage service uses this information
--  to save the data in a file, in the database or in a remote service (in the future).
--
--    Data.Set_Storage (Storage => AWA.Storages.Models.DATABASE);
--
--  To save a file in the store, we can use the `Save` operation.  It will read the file
--  and put in in the corresponding persistent store (the database in this example).
--
--    Service.Save (Into => Data, Path => Path_To_The_File);
--
--  Upon successful completion, the storage instance `Data` will be allocated a unique
--  identifier that can be retrieved by `Get_Id` or `Get_Key`.
--
--  == Getting the data ==
--  Several operations are defined to retrieve the data.  Each of them has been designed
--  to optimize the retrieval and
--
--    * The data can be retrieved in a local file.
--      This mode is useful if an external program must be launched and be able to read
--      the file.  If the storage mode of the data is `FILE`, the path of the file on
--      the storage file system is used.  For other storage modes, the file is saved
--      in a temporary file.  In that case the `Store_Local` database table is used
--      to track such locally saved data.
--    * The data can be returned as a stream.
--      When the application has to read the data, opening a read stream connection is
--      the most efficient mechanism.
--
--  To access the data by using a local file, we must define a local storage reference:
--
--    Data : AWA.Storages.Models.Store_Local_Ref;
--
--  and use the `Load` operation with the storage identifier:
--
--    Service.Load (From => Id, Into => Data);
--
--  Once the load operation succeeded, the data is stored on the file system and
--  the local path is obtained by using the `Get_Path` operation:
--
--    Path : constant String := Data.Get_Path;
--
--  == Ada Beans ==
--  @include storages.xml
--
--  == Model ==
--  [http://ada-awa.googlecode.com/svn/wiki/awa_storage_model.png]
--
--  @include Storages.hbm.xml
package AWA.Storages is

end AWA.Storages;

Document how to retrieve the data

Document how to retrieve the data


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

--  The Util.Encodes.Base64 packages encodes and decodes streams
--  in Base64 (See rfc4648: The Base16, Base32, and Base64 Data Encodings).
package Util.Encoders.Base64 is

   pragma Preelaborate;

   --  ------------------------------
   --  Base64 encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  a Base64 ascii stream.
   type Encoder is new Util.Encoders.Transformer with private;

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

   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean);

   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   function Create_URL_Encoder return Transformer_Access;

   --  ------------------------------
   --  Base64 decoder
   --  ------------------------------
   --  The Decoder decodes a Base64 ascii stream into a binary stream.
   type Decoder is new Util.Encoders.Transformer with private;

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

   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean);

   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   function Create_URL_Decoder return Transformer_Access;

private

   type Alphabet is
     array (Interfaces.Unsigned_8 range 0 .. 63) of Ada.Streams.Stream_Element;

   type Alphabet_Access is not null access constant Alphabet;

   BASE64_ALPHABET : aliased constant Alphabet :=
     (Character'Pos ('A'), Character'Pos ('B'), Character'Pos ('C'), Character'Pos ('D'),
      Character'Pos ('E'), Character'Pos ('F'), Character'Pos ('G'), Character'Pos ('H'),
      Character'Pos ('I'), Character'Pos ('J'), Character'Pos ('K'), Character'Pos ('L'),
      Character'Pos ('M'), Character'Pos ('N'), Character'Pos ('O'), Character'Pos ('P'),
      Character'Pos ('Q'), Character'Pos ('R'), Character'Pos ('S'), Character'Pos ('T'),
      Character'Pos ('U'), Character'Pos ('V'), Character'Pos ('W'), Character'Pos ('X'),
      Character'Pos ('Y'), Character'Pos ('Z'), Character'Pos ('a'), Character'Pos ('b'),
      Character'Pos ('c'), Character'Pos ('d'), Character'Pos ('e'), Character'Pos ('f'),
      Character'Pos ('g'), Character'Pos ('h'), Character'Pos ('i'), Character'Pos ('j'),
      Character'Pos ('k'), Character'Pos ('l'), Character'Pos ('m'), Character'Pos ('n'),
      Character'Pos ('o'), Character'Pos ('p'), Character'Pos ('q'), Character'Pos ('r'),
      Character'Pos ('s'), Character'Pos ('t'), Character'Pos ('u'), Character'Pos ('v'),
      Character'Pos ('w'), Character'Pos ('x'), Character'Pos ('y'), Character'Pos ('z'),
      Character'Pos ('0'), Character'Pos ('1'), Character'Pos ('2'), Character'Pos ('3'),
      Character'Pos ('4'), Character'Pos ('5'), Character'Pos ('6'), Character'Pos ('7'),
      Character'Pos ('8'), Character'Pos ('9'), Character'Pos ('+'), Character'Pos ('/'));

   BASE64_URL_ALPHABET : aliased constant Alphabet :=
     (Character'Pos ('A'), Character'Pos ('B'), Character'Pos ('C'), Character'Pos ('D'),
      Character'Pos ('E'), Character'Pos ('F'), Character'Pos ('G'), Character'Pos ('H'),
      Character'Pos ('I'), Character'Pos ('J'), Character'Pos ('K'), Character'Pos ('L'),
      Character'Pos ('M'), Character'Pos ('N'), Character'Pos ('O'), Character'Pos ('P'),
      Character'Pos ('Q'), Character'Pos ('R'), Character'Pos ('S'), Character'Pos ('T'),
      Character'Pos ('U'), Character'Pos ('V'), Character'Pos ('W'), Character'Pos ('X'),
      Character'Pos ('Y'), Character'Pos ('Z'), Character'Pos ('a'), Character'Pos ('b'),
      Character'Pos ('c'), Character'Pos ('d'), Character'Pos ('e'), Character'Pos ('f'),
      Character'Pos ('g'), Character'Pos ('h'), Character'Pos ('i'), Character'Pos ('j'),
      Character'Pos ('k'), Character'Pos ('l'), Character'Pos ('m'), Character'Pos ('n'),
      Character'Pos ('o'), Character'Pos ('p'), Character'Pos ('q'), Character'Pos ('r'),
      Character'Pos ('s'), Character'Pos ('t'), Character'Pos ('u'), Character'Pos ('v'),
      Character'Pos ('w'), Character'Pos ('x'), Character'Pos ('y'), Character'Pos ('z'),
      Character'Pos ('0'), Character'Pos ('1'), Character'Pos ('2'), Character'Pos ('3'),
      Character'Pos ('4'), Character'Pos ('5'), Character'Pos ('6'), Character'Pos ('7'),
      Character'Pos ('8'), Character'Pos ('9'), Character'Pos ('-'), Character'Pos ('_'));

   type Encoder is new Util.Encoders.Transformer with record
      Alphabet : Alphabet_Access := BASE64_ALPHABET'Access;
   end record;

   type Alphabet_Values is array (Ada.Streams.Stream_Element) of Interfaces.Unsigned_8;
   type Alphabet_Values_Access is not null access constant Alphabet_Values;

   BASE64_VALUES : aliased constant Alphabet_Values :=
     (Character'Pos ('A') => 0,  Character'Pos ('B') => 1,
      Character'Pos ('C') => 2,  Character'Pos ('D') => 3,
      Character'Pos ('E') => 4,  Character'Pos ('F') => 5,
      Character'Pos ('G') => 6,  Character'Pos ('H') => 7,
      Character'Pos ('I') => 8,  Character'Pos ('J') => 9,
      Character'Pos ('K') => 10, Character'Pos ('L') => 11,
      Character'Pos ('M') => 12, Character'Pos ('N') => 13,
      Character'Pos ('O') => 14, Character'Pos ('P') => 15,
      Character'Pos ('Q') => 16, Character'Pos ('R') => 17,
      Character'Pos ('S') => 18, Character'Pos ('T') => 19,
      Character'Pos ('U') => 20, Character'Pos ('V') => 21,
      Character'Pos ('W') => 22, Character'Pos ('X') => 23,
      Character'Pos ('Y') => 24, Character'Pos ('Z') => 25,
      Character'Pos ('a') => 26, Character'Pos ('b') => 27,
      Character'Pos ('c') => 28, Character'Pos ('d') => 29,
      Character'Pos ('e') => 30, Character'Pos ('f') => 31,
      Character'Pos ('g') => 32, Character'Pos ('h') => 33,
      Character'Pos ('i') => 34, Character'Pos ('j') => 35,
      Character'Pos ('k') => 36, Character'Pos ('l') => 37,
      Character'Pos ('m') => 38, Character'Pos ('n') => 39,
      Character'Pos ('o') => 40, Character'Pos ('p') => 41,
      Character'Pos ('q') => 42, Character'Pos ('r') => 43,
      Character'Pos ('s') => 44, Character'Pos ('t') => 45,
      Character'Pos ('u') => 46, Character'Pos ('v') => 47,
      Character'Pos ('w') => 48, Character'Pos ('x') => 49,
      Character'Pos ('y') => 50, Character'Pos ('z') => 51,
      Character'Pos ('0') => 52, Character'Pos ('1') => 53,
      Character'Pos ('2') => 54, Character'Pos ('3') => 55,
      Character'Pos ('4') => 56, Character'Pos ('5') => 57,
      Character'Pos ('6') => 58, Character'Pos ('7') => 59,
      Character'Pos ('8') => 60, Character'Pos ('9') => 61,
      Character'Pos ('+') => 62, Character'Pos ('/') => 63,
     others => 16#FF#);

   BASE64_URL_VALUES : aliased constant Alphabet_Values :=
     (Character'Pos ('A') => 0,  Character'Pos ('B') => 1,
      Character'Pos ('C') => 2,  Character'Pos ('D') => 3,
      Character'Pos ('E') => 4,  Character'Pos ('F') => 5,
      Character'Pos ('G') => 6,  Character'Pos ('H') => 7,
      Character'Pos ('I') => 8,  Character'Pos ('J') => 9,
      Character'Pos ('K') => 10, Character'Pos ('L') => 11,
      Character'Pos ('M') => 12, Character'Pos ('N') => 13,
      Character'Pos ('O') => 14, Character'Pos ('P') => 15,
      Character'Pos ('Q') => 16, Character'Pos ('R') => 17,
      Character'Pos ('S') => 18, Character'Pos ('T') => 19,
      Character'Pos ('U') => 20, Character'Pos ('V') => 21,
      Character'Pos ('W') => 22, Character'Pos ('X') => 23,
      Character'Pos ('Y') => 24, Character'Pos ('Z') => 25,
      Character'Pos ('a') => 26, Character'Pos ('b') => 27,
      Character'Pos ('c') => 28, Character'Pos ('d') => 29,
      Character'Pos ('e') => 30, Character'Pos ('f') => 31,
      Character'Pos ('g') => 32, Character'Pos ('h') => 33,
      Character'Pos ('i') => 34, Character'Pos ('j') => 35,
      Character'Pos ('k') => 36, Character'Pos ('l') => 37,
      Character'Pos ('m') => 38, Character'Pos ('n') => 39,
      Character'Pos ('o') => 40, Character'Pos ('p') => 41,
      Character'Pos ('q') => 42, Character'Pos ('r') => 43,
      Character'Pos ('s') => 44, Character'Pos ('t') => 45,
      Character'Pos ('u') => 46, Character'Pos ('v') => 47,
      Character'Pos ('w') => 48, Character'Pos ('x') => 49,
      Character'Pos ('y') => 50, Character'Pos ('z') => 51,
      Character'Pos ('0') => 52, Character'Pos ('1') => 53,
      Character'Pos ('2') => 54, Character'Pos ('3') => 55,
      Character'Pos ('4') => 56, Character'Pos ('5') => 57,
      Character'Pos ('6') => 58, Character'Pos ('7') => 59,
      Character'Pos ('8') => 60, Character'Pos ('9') => 61,
      Character'Pos ('-') => 62, Character'Pos ('_') => 63,
      others => 16#FF#);

   type Decoder is new Util.Encoders.Transformer with record
      Values : Alphabet_Values_Access := BASE64_VALUES'Access;
   end record;

end Util.Encoders.Base64;

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

--  The Util.Encodes.Base64 packages encodes and decodes streams
--  in Base64 (See rfc4648: The Base16, Base32, and Base64 Data Encodings).
package Util.Encoders.Base64 is

   pragma Preelaborate;

   --  Encode the 64-bit value to LEB128 and then base64url.
   function Encode (Value : in Interfaces.Unsigned_64) return String;

   --  Decode the base64url string and then the LEB128 integer.
   --  Raise the Encoding_Error if the string is invalid and cannot be decoded.
   function Decode (Value : in String) return Interfaces.Unsigned_64;

   --  ------------------------------
   --  Base64 encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  a Base64 ascii stream.
   type Encoder is new Util.Encoders.Transformer with private;

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

   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean);

   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   function Create_URL_Encoder return Transformer_Access;

   --  ------------------------------
   --  Base64 decoder
   --  ------------------------------
   --  The Decoder decodes a Base64 ascii stream into a binary stream.
   type Decoder is new Util.Encoders.Transformer with private;

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

   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean);

   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   function Create_URL_Decoder return Transformer_Access;

private

   type Alphabet is
     array (Interfaces.Unsigned_8 range 0 .. 63) of Ada.Streams.Stream_Element;

   type Alphabet_Access is not null access constant Alphabet;

   BASE64_ALPHABET : aliased constant Alphabet :=
     (Character'Pos ('A'), Character'Pos ('B'), Character'Pos ('C'), Character'Pos ('D'),
      Character'Pos ('E'), Character'Pos ('F'), Character'Pos ('G'), Character'Pos ('H'),
      Character'Pos ('I'), Character'Pos ('J'), Character'Pos ('K'), Character'Pos ('L'),
      Character'Pos ('M'), Character'Pos ('N'), Character'Pos ('O'), Character'Pos ('P'),
      Character'Pos ('Q'), Character'Pos ('R'), Character'Pos ('S'), Character'Pos ('T'),
      Character'Pos ('U'), Character'Pos ('V'), Character'Pos ('W'), Character'Pos ('X'),
      Character'Pos ('Y'), Character'Pos ('Z'), Character'Pos ('a'), Character'Pos ('b'),
      Character'Pos ('c'), Character'Pos ('d'), Character'Pos ('e'), Character'Pos ('f'),
      Character'Pos ('g'), Character'Pos ('h'), Character'Pos ('i'), Character'Pos ('j'),
      Character'Pos ('k'), Character'Pos ('l'), Character'Pos ('m'), Character'Pos ('n'),
      Character'Pos ('o'), Character'Pos ('p'), Character'Pos ('q'), Character'Pos ('r'),
      Character'Pos ('s'), Character'Pos ('t'), Character'Pos ('u'), Character'Pos ('v'),
      Character'Pos ('w'), Character'Pos ('x'), Character'Pos ('y'), Character'Pos ('z'),
      Character'Pos ('0'), Character'Pos ('1'), Character'Pos ('2'), Character'Pos ('3'),
      Character'Pos ('4'), Character'Pos ('5'), Character'Pos ('6'), Character'Pos ('7'),
      Character'Pos ('8'), Character'Pos ('9'), Character'Pos ('+'), Character'Pos ('/'));

   BASE64_URL_ALPHABET : aliased constant Alphabet :=
     (Character'Pos ('A'), Character'Pos ('B'), Character'Pos ('C'), Character'Pos ('D'),
      Character'Pos ('E'), Character'Pos ('F'), Character'Pos ('G'), Character'Pos ('H'),
      Character'Pos ('I'), Character'Pos ('J'), Character'Pos ('K'), Character'Pos ('L'),
      Character'Pos ('M'), Character'Pos ('N'), Character'Pos ('O'), Character'Pos ('P'),
      Character'Pos ('Q'), Character'Pos ('R'), Character'Pos ('S'), Character'Pos ('T'),
      Character'Pos ('U'), Character'Pos ('V'), Character'Pos ('W'), Character'Pos ('X'),
      Character'Pos ('Y'), Character'Pos ('Z'), Character'Pos ('a'), Character'Pos ('b'),
      Character'Pos ('c'), Character'Pos ('d'), Character'Pos ('e'), Character'Pos ('f'),
      Character'Pos ('g'), Character'Pos ('h'), Character'Pos ('i'), Character'Pos ('j'),
      Character'Pos ('k'), Character'Pos ('l'), Character'Pos ('m'), Character'Pos ('n'),
      Character'Pos ('o'), Character'Pos ('p'), Character'Pos ('q'), Character'Pos ('r'),
      Character'Pos ('s'), Character'Pos ('t'), Character'Pos ('u'), Character'Pos ('v'),
      Character'Pos ('w'), Character'Pos ('x'), Character'Pos ('y'), Character'Pos ('z'),
      Character'Pos ('0'), Character'Pos ('1'), Character'Pos ('2'), Character'Pos ('3'),
      Character'Pos ('4'), Character'Pos ('5'), Character'Pos ('6'), Character'Pos ('7'),
      Character'Pos ('8'), Character'Pos ('9'), Character'Pos ('-'), Character'Pos ('_'));

   type Encoder is new Util.Encoders.Transformer with record
      Alphabet : Alphabet_Access := BASE64_ALPHABET'Access;
   end record;

   type Alphabet_Values is array (Ada.Streams.Stream_Element) of Interfaces.Unsigned_8;
   type Alphabet_Values_Access is not null access constant Alphabet_Values;

   BASE64_VALUES : aliased constant Alphabet_Values :=
     (Character'Pos ('A') => 0,  Character'Pos ('B') => 1,
      Character'Pos ('C') => 2,  Character'Pos ('D') => 3,
      Character'Pos ('E') => 4,  Character'Pos ('F') => 5,
      Character'Pos ('G') => 6,  Character'Pos ('H') => 7,
      Character'Pos ('I') => 8,  Character'Pos ('J') => 9,
      Character'Pos ('K') => 10, Character'Pos ('L') => 11,
      Character'Pos ('M') => 12, Character'Pos ('N') => 13,
      Character'Pos ('O') => 14, Character'Pos ('P') => 15,
      Character'Pos ('Q') => 16, Character'Pos ('R') => 17,
      Character'Pos ('S') => 18, Character'Pos ('T') => 19,
      Character'Pos ('U') => 20, Character'Pos ('V') => 21,
      Character'Pos ('W') => 22, Character'Pos ('X') => 23,
      Character'Pos ('Y') => 24, Character'Pos ('Z') => 25,
      Character'Pos ('a') => 26, Character'Pos ('b') => 27,
      Character'Pos ('c') => 28, Character'Pos ('d') => 29,
      Character'Pos ('e') => 30, Character'Pos ('f') => 31,
      Character'Pos ('g') => 32, Character'Pos ('h') => 33,
      Character'Pos ('i') => 34, Character'Pos ('j') => 35,
      Character'Pos ('k') => 36, Character'Pos ('l') => 37,
      Character'Pos ('m') => 38, Character'Pos ('n') => 39,
      Character'Pos ('o') => 40, Character'Pos ('p') => 41,
      Character'Pos ('q') => 42, Character'Pos ('r') => 43,
      Character'Pos ('s') => 44, Character'Pos ('t') => 45,
      Character'Pos ('u') => 46, Character'Pos ('v') => 47,
      Character'Pos ('w') => 48, Character'Pos ('x') => 49,
      Character'Pos ('y') => 50, Character'Pos ('z') => 51,
      Character'Pos ('0') => 52, Character'Pos ('1') => 53,
      Character'Pos ('2') => 54, Character'Pos ('3') => 55,
      Character'Pos ('4') => 56, Character'Pos ('5') => 57,
      Character'Pos ('6') => 58, Character'Pos ('7') => 59,
      Character'Pos ('8') => 60, Character'Pos ('9') => 61,
      Character'Pos ('+') => 62, Character'Pos ('/') => 63,
     others => 16#FF#);

   BASE64_URL_VALUES : aliased constant Alphabet_Values :=
     (Character'Pos ('A') => 0,  Character'Pos ('B') => 1,
      Character'Pos ('C') => 2,  Character'Pos ('D') => 3,
      Character'Pos ('E') => 4,  Character'Pos ('F') => 5,
      Character'Pos ('G') => 6,  Character'Pos ('H') => 7,
      Character'Pos ('I') => 8,  Character'Pos ('J') => 9,
      Character'Pos ('K') => 10, Character'Pos ('L') => 11,
      Character'Pos ('M') => 12, Character'Pos ('N') => 13,
      Character'Pos ('O') => 14, Character'Pos ('P') => 15,
      Character'Pos ('Q') => 16, Character'Pos ('R') => 17,
      Character'Pos ('S') => 18, Character'Pos ('T') => 19,
      Character'Pos ('U') => 20, Character'Pos ('V') => 21,
      Character'Pos ('W') => 22, Character'Pos ('X') => 23,
      Character'Pos ('Y') => 24, Character'Pos ('Z') => 25,
      Character'Pos ('a') => 26, Character'Pos ('b') => 27,
      Character'Pos ('c') => 28, Character'Pos ('d') => 29,
      Character'Pos ('e') => 30, Character'Pos ('f') => 31,
      Character'Pos ('g') => 32, Character'Pos ('h') => 33,
      Character'Pos ('i') => 34, Character'Pos ('j') => 35,
      Character'Pos ('k') => 36, Character'Pos ('l') => 37,
      Character'Pos ('m') => 38, Character'Pos ('n') => 39,
      Character'Pos ('o') => 40, Character'Pos ('p') => 41,
      Character'Pos ('q') => 42, Character'Pos ('r') => 43,
      Character'Pos ('s') => 44, Character'Pos ('t') => 45,
      Character'Pos ('u') => 46, Character'Pos ('v') => 47,
      Character'Pos ('w') => 48, Character'Pos ('x') => 49,
      Character'Pos ('y') => 50, Character'Pos ('z') => 51,
      Character'Pos ('0') => 52, Character'Pos ('1') => 53,
      Character'Pos ('2') => 54, Character'Pos ('3') => 55,
      Character'Pos ('4') => 56, Character'Pos ('5') => 57,
      Character'Pos ('6') => 58, Character'Pos ('7') => 59,
      Character'Pos ('8') => 60, Character'Pos ('9') => 61,
      Character'Pos ('-') => 62, Character'Pos ('_') => 63,
      others => 16#FF#);

   type Decoder is new Util.Encoders.Transformer with record
      Values : Alphabet_Values_Access := BASE64_VALUES'Access;
   end record;

end Util.Encoders.Base64;

Declare the Encode and Decode function for integer <-> string conversion using LEB128 + base64url


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

   type File_Reader_Type is new Manager_Base with private;

   --  Open the file.
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String);

   procedure Read_All (Reader : in out File_Reader_Type);

private

   type File_Reader_Type is new Manager_Base with record
      Stream : Util.Streams.Buffered.Buffered_Stream;
      File   : aliased Util.Streams.Files.File_Stream;
   end record;

end MAT.Readers.Files;

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

   type File_Reader_Type is new Manager_Base with private;

   --  Open the file.
   procedure Open (Reader : in out File_Reader_Type;
                   Path   : in String);

   procedure Read_All (Reader : in out File_Reader_Type);

private

   type File_Reader_Type is new Manager_Base with record
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Streams.Buffered.Buffered_Stream;
   end record;

end MAT.Readers.Files;

Fix finalization of File_Reader_Type

Fix finalization of File_Reader_Type


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

with Ada.Directories;
with Util.Test_Caller;
package body Util.Files.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Files");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
         end if;
         Last := To_Unbounded_String (Dir);
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;a", Check_Path'Access, Ada.Strings.Backward);
      Assert_Equals (T, "de", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

end Util.Files.Tests;

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

with Ada.Directories;
with Util.Test_Caller;
package body Util.Files.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Files");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Files.Read_File",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (missing)",
                       Test_Read_File_Missing'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Read_File (truncate)",
                       Test_Read_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Write_File",
                       Test_Write_File'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Iterate_Path",
                       Test_Iterate_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Find_File_Path",
                       Test_Find_File_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Compose_Path",
                       Test_Compose_Path'Access);
      Caller.Add_Test (Suite, "Test Util.Files.Get_Relative_Path",
                       Test_Get_Relative_Path'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a file into a string
   --  Reads this ada source file and checks we have read it correctly
   --  ------------------------------
   procedure Test_Read_File (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result);
      T.Assert (Index (Result, "Util.Files.Tests") > 0,
                "Content returned by Read_File is not correct");
      T.Assert (Index (Result, "end Util.Files.Tests;") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File;

   procedure Test_Read_File_Missing (T : in out Test) is
      Result : Unbounded_String;

      pragma Unreferenced (Result);
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

   procedure Test_Read_File_Truncate (T : in out Test) is
      Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/util-files-tests.adb", Into => Result,
                 Max_Size => 50);
      Assert_Equals (T, Length (Result), 50,
                     "Read_File did not truncate correctly");
      T.Assert (Index (Result, "Apache License") > 0,
                "Content returned by Read_File is not correct");
   end Test_Read_File_Truncate;

   --  ------------------------------
   --  Check writing a file
   --  ------------------------------
   procedure Test_Write_File (T : in out Test) is
      Path   : constant String := Util.Tests.Get_Test_Path ("test-write.txt");
      Content : constant String := "Testing Util.Files.Write_File" & ASCII.LF;
      Result : Unbounded_String;
   begin
      Write_File (Path => Path, Content => Content);
      Read_File (Path => Path, Into => Result);
      Assert_Equals (T, To_String (Result), Content,
                     "Invalid content written or read");
   end Test_Write_File;

   --  ------------------------------
   --  Check Find_File_Path
   --  ------------------------------
   procedure Test_Find_File_Path (T : in out Test) is
      Dir   : constant String := Util.Tests.Get_Path ("regtests");
      Paths : constant String := ".;" & Dir;
   begin
      declare
         P : constant String := Util.Files.Find_File_Path ("test.properties", Paths);
      begin
         Assert_Equals (T, Dir & "/test.properties", P,
                        "Invalid path returned");
      end;
      Assert_Equals (T, "blablabla.properties",
                     Util.Files.Find_File_Path ("blablabla.properties", Paths));
   end Test_Find_File_Path;

   --  ------------------------------
   --  Check Iterate_Path
   --  ------------------------------
   procedure Test_Iterate_Path (T : in out Test) is
      procedure Check_Path (Dir : in String;
                            Done : out Boolean);

      Last : Unbounded_String;

      procedure Check_Path (Dir : in String;
                            Done : out Boolean) is
      begin
         if Dir = "a" or Dir = "bc" or Dir = "de" then
            Done := False;
         else
            Done := True;
         end if;
         Last := To_Unbounded_String (Dir);
      end Check_Path;

   begin
      Iterate_Path ("a;bc;de;f", Check_Path'Access);
      Assert_Equals (T, "f", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;b", Check_Path'Access);
      Assert_Equals (T, "b", Last, "Invalid last path");

      Iterate_Path ("de;bc;de;a", Check_Path'Access, Ada.Strings.Backward);
      Assert_Equals (T, "de", Last, "Invalid last path");

   end Test_Iterate_Path;

   --  ------------------------------
   --  Test the Compose_Path operation
   --  ------------------------------
   procedure Test_Compose_Path (T : in out Test) is
   begin
      Assert_Equals (T, "src/os-none",
                     Compose_Path ("src;regtests", "os-none"),
                     "Invalid path composition");
      Assert_Equals (T, "regtests/bundles",
                     Compose_Path ("src;regtests", "bundles"),
                     "Invalid path composition");
      if Ada.Directories.Exists ("/usr/bin") then
         Assert_Equals (T, "/usr/bin;/usr/local/bin;/usr/bin",
                        Compose_Path ("/usr;/usr/local;/usr", "bin"),
                        "Invalid path composition");
      end if;
   end Test_Compose_Path;

   --  ------------------------------
   --  Test the Get_Relative_Path operation.
   --  ------------------------------
   procedure Test_Get_Relative_Path (T : in out Test) is
   begin
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util",
                     Get_Relative_Path ("/home/john/src/asf/", "/home/john/src/util"),
                     "Invalid relative path");
      Assert_Equals (T, "../util/b",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/util/b"),
                     "Invalid relative path");
      Assert_Equals (T, "../as",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/as"),
                     "Invalid relative path");
      Assert_Equals (T, "../../",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "/usr/share/admin",
                     Get_Relative_Path ("/home/john/src/asf", "/usr/share/admin"),
                     "Invalid absolute path");
      Assert_Equals (T, "/home/john",
                     Get_Relative_Path ("home/john/src/asf", "/home/john"),
                     "Invalid relative path");
      Assert_Equals (T, "e",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/e"),
                     "Invalid relative path");
      Assert_Equals (T, ".",
                     Get_Relative_Path ("/home/john/src/asf", "/home/john/src/asf/"),
                     "Invalid relative path");
   end Test_Get_Relative_Path;

end Util.Files.Tests;

Fix a test case that was not executed

Fix a test case that was not executed


-----------------------------------------------------------------------
--  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.
-----------------------------------------------------------------------

package body Util.Concurrent.Counters is

   use Interfaces;

   function Sync_Add_And_Fetch
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Add_And_Fetch,
                  External_Name => "__sync_add_and_fetch_4");

   function Sync_Fetch_And_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Fetch_And_Add,
                  External_Name => "__sync_fetch_and_add_4");

   procedure Sync_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Add,
                  External_Name => "__sync_add_and_fetch_4");

   --  ------------------------------
   --  Increment the counter atomically.
   --  ------------------------------
   procedure Increment (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, 1);
   end Increment;

   --  ------------------------------
   --  Increment the counter atomically and return the value before increment.
   --  ------------------------------
   procedure Increment (C     : in out Counter;
                        Value : out Integer) is
   begin
      Value := Integer (Sync_Fetch_And_Add (C.Value'Unrestricted_Access, 1));
   end Increment;

   --  ------------------------------
   --  Decrement the counter atomically.
   --  ------------------------------
   procedure Decrement (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, -1);
   end Decrement;

   --  ------------------------------
   --  Decrement the counter atomically and return a status.
   --  ------------------------------
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean) is
      Value : Unsigned_32;
   begin
      Value := Sync_Add_And_Fetch (C.Value'Unrestricted_Access, -1);
      Is_Zero := Value /= 0;
   end Decrement;

   --  ------------------------------
   --  Get the counter value
   --  ------------------------------
   function Value (C : in Counter) return Integer is
   begin
      return Integer (C.Value);
   end Value;

end Util.Concurrent.Counters;

-----------------------------------------------------------------------
--  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.
-----------------------------------------------------------------------

package body Util.Concurrent.Counters is

   use Interfaces;

   function Sync_Add_And_Fetch
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Add_And_Fetch,
                  External_Name => "__sync_add_and_fetch_4");

   function Sync_Fetch_And_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Fetch_And_Add,
                  External_Name => "__sync_fetch_and_add_4");

   procedure Sync_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Add,
                  External_Name => "__sync_add_and_fetch_4");

   --  ------------------------------
   --  Increment the counter atomically.
   --  ------------------------------
   procedure Increment (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, 1);
   end Increment;

   --  ------------------------------
   --  Increment the counter atomically and return the value before increment.
   --  ------------------------------
   procedure Increment (C     : in out Counter;
                        Value : out Integer) is
   begin
      Value := Integer (Sync_Fetch_And_Add (C.Value'Unrestricted_Access, 1));
   end Increment;

   --  ------------------------------
   --  Decrement the counter atomically.
   --  ------------------------------
   procedure Decrement (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, -1);
   end Decrement;

   --  ------------------------------
   --  Decrement the counter atomically and return a status.
   --  ------------------------------
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean) is
      Value : Unsigned_32;
   begin
      Value := Sync_Add_And_Fetch (C.Value'Unrestricted_Access, -1);
      Is_Zero := Value = 0;
   end Decrement;

   --  ------------------------------
   --  Get the counter value
   --  ------------------------------
   function Value (C : in Counter) return Integer is
   begin
      return Integer (C.Value);
   end Value;

end Util.Concurrent.Counters;

Fix the Is_Zero test

Fix the Is_Zero test


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

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
with MAT.Events.Targets;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Inside_Type is (INSIDE_FILE,
                        INSIDE_DIRECT_FILE,
                        INSIDE_FUNCTION,
                        INSIDE_DIRECT_FUNCTION);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a OR expression node.
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type;

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

   --  Create an event ID range expression node.
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean;

   --  Parse the string and return the expression tree.
   function Parse (Expr : in String) return Expression_Type;

   --  Empty expression.
   EMPTY : constant Expression_Type;

private

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT, N_INSIDE,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_RANGE_TIME, N_EVENT,
                      N_CONDITION, N_THREAD);

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_INSIDE | N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name   : Ada.Strings.Unbounded.Unbounded_String;
            Inside : Inside_Type;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

         when N_THREAD =>
            Thread : MAT.Types.Target_Thread_Ref;

         when N_EVENT =>
            Min_Event : MAT.Events.Targets.Event_Id_Type;
            Max_Event : MAT.Events.Targets.Event_Id_Type;

         when others =>
            null;
      end case;
   end record;

   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean;

   type Expression_Type is new Ada.Finalization.Controlled with record
      Node : Node_Type_Access;
   end record;

   --  Release the reference and destroy the expression tree if it was the last reference.
   overriding
   procedure Finalize (Obj : in out Expression_Type);

   --  Update the reference after an assignment.
   overriding
   procedure Adjust (Obj : in out Expression_Type);

   --  Empty expression.
   EMPTY : constant Expression_Type := Expression_Type'(Ada.Finalization.Controlled with
                                                        Node => null);

end MAT.Expressions;

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

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
with MAT.Events.Targets;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Inside_Type is (INSIDE_FILE,
                        INSIDE_DIRECT_FILE,
                        INSIDE_FUNCTION,
                        INSIDE_DIRECT_FUNCTION);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a OR expression node.
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type;

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

   --  Create an event ID range expression node.
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type;

   --  Create a thread ID range expression node.
   function Create_Thread (Min : in MAT.Types.Target_Thread_Ref;
                           Max : in MAT.Types.Target_Thread_Ref) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean;

   --  Parse the string and return the expression tree.
   function Parse (Expr : in String) return Expression_Type;

   --  Empty expression.
   EMPTY : constant Expression_Type;

private

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT, N_INSIDE,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_RANGE_TIME, N_EVENT,
                      N_CONDITION, N_THREAD);

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_INSIDE | N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name   : Ada.Strings.Unbounded.Unbounded_String;
            Inside : Inside_Type;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

         when N_THREAD =>
            Min_Thread : MAT.Types.Target_Thread_Ref;
            Max_Thread : MAT.Types.Target_Thread_Ref;

         when N_EVENT =>
            Min_Event : MAT.Events.Targets.Event_Id_Type;
            Max_Event : MAT.Events.Targets.Event_Id_Type;

         when others =>
            null;
      end case;
   end record;

   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean;

   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean;

   type Expression_Type is new Ada.Finalization.Controlled with record
      Node : Node_Type_Access;
   end record;

   --  Release the reference and destroy the expression tree if it was the last reference.
   overriding
   procedure Finalize (Obj : in out Expression_Type);

   --  Update the reference after an assignment.
   overriding
   procedure Adjust (Obj : in out Expression_Type);

   --  Empty expression.
   EMPTY : constant Expression_Type := Expression_Type'(Ada.Finalization.Controlled with
                                                        Node => null);

end MAT.Expressions;

Declare the Create_Thread function to create a thread id expression node


------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1 .. Buffer.Used + Data'Length)
        := Data;
      Buffer.Used := Buffer.Used + Data'Length;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all;
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         return Atom_Refs.Create (Create'Access).Query;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Buffer.Ref.Query (Process);
      end if;
   end Query;

   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Read;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

end Natools.S_Expressions.Atom_Buffers;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Atom_Buffers is

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count) is
      Old_Size, New_Size : Count := 0;
   begin
      if Buffer.Used + Length <= Buffer.Available then
         return;
      end if;

      Old_Size := Buffer.Available;
      New_Size := Buffer.Used + Length;

      if Buffer.Ref.Is_Empty then
         declare
            function Create return Atom;

            function Create return Atom is
            begin
               return Atom'(1 .. New_Size => <>);
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      else
         declare
            function Create return Atom;

            Old_Accessor : constant Atom_Refs.Accessor := Buffer.Ref.Query;

            function Create return Atom is
            begin
               return Result : Atom (1 .. New_Size) do
                  Result (1 .. Old_Size) := Old_Accessor.Data.all;
               end return;
            end Create;
         begin
            Buffer.Ref.Replace (Create'Access);
         end;
      end if;

      Buffer.Available := New_Size;
   end Preallocate;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom) is
   begin
      Preallocate (Buffer, Data'Length);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1 .. Buffer.Used + Data'Length)
        := Data;
      Buffer.Used := Buffer.Used + Data'Length;
   end Append;

   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet) is
   begin
      Preallocate (Buffer, 1);
      Buffer.Ref.Update.Data.all (Buffer.Used + 1) := Data;
      Buffer.Used := Buffer.Used + 1;
   end Append;

   function Length (Buffer : Atom_Buffer) return Count is
   begin
      return Buffer.Used;
   end Length;

   function Data (Buffer : Atom_Buffer) return Atom is
   begin
      if Buffer.Ref.Is_Empty then
         pragma Assert (Buffer.Available = 0 and Buffer.Used = 0);
         return Null_Atom;
      else
         return Buffer.Ref.Query.Data.all (1 .. Buffer.Used);
      end if;
   end Data;

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor is
      function Create return Atom;

      function Create return Atom is
      begin
         return Null_Atom;
      end Create;
   begin
      if Buffer.Ref.Is_Empty then
         return Atom_Refs.Create (Create'Access).Query;
      else
         return Buffer.Ref.Query;
      end if;
   end Raw_Query;

   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Buffer.Ref.Is_Empty then
         Process.all (Null_Atom);
      else
         Process.all (Buffer.Ref.Query.Data.all (1 .. Buffer.Used));
      end if;
   end Query;

   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count)
   is
      Transmit : constant Count := Count'Min (Data'Length, Buffer.Used);
   begin
      Length := Buffer.Used;

      if Buffer.Ref.Is_Empty then
         pragma Assert (Length = 0);
         null;
      else
         Data (Data'First .. Data'First + Transmit - 1)
           := Buffer.Ref.Query.Data.all (1 .. Transmit);
      end if;
   end Read;

   function Element (Buffer : Atom_Buffer; Position : Count) return Octet is
   begin
      return Buffer.Ref.Query.Data.all (Position);
   end Element;

   procedure Hard_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Ref.Reset;
      Buffer.Available := 0;
      Buffer.Used := 0;
   end Hard_Reset;

   procedure Soft_Reset (Buffer : in out Atom_Buffer) is
   begin
      Buffer.Used := 0;
   end Soft_Reset;

end Natools.S_Expressions.Atom_Buffers;

s_expressions-atom_buffers: fix accessors to return only used part of the buffer


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

with Gtk.Main;
with Gtk.Widget;
package body MAT.Callbacks is

   --  ------------------------------
   --  Callback executed when the "quit" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_Quit (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end On_Menu_Quit;

   --  ------------------------------
   --  Callback executed when the "about" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_About (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
      About : constant Gtk.Widget.Gtk_Widget :=
        Gtk.Widget.Gtk_Widget (Object.Get_Object ("about"));
   begin
      About.Show;
   end On_Menu_About;

end MAT.Callbacks;

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

with Gtk.Main;
with Gtk.Widget;
package body MAT.Callbacks is

   --  ------------------------------
   --  Callback executed when the "quit" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_Quit (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
   begin
      Gtk.Main.Main_Quit;
   end On_Menu_Quit;

   --  ------------------------------
   --  Callback executed when the "about" action is executed from the menu.
   --  ------------------------------
   procedure On_Menu_About (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
      About : constant Gtk.Widget.Gtk_Widget :=
        Gtk.Widget.Gtk_Widget (Object.Get_Object ("about"));
   begin
      About.Show;
   end On_Menu_About;

   --  ------------------------------
   --  Callback executed when the "close-about" action is executed from the about box.
   --  ------------------------------
   procedure On_Close_About (Object : access Gtkada.Builder.Gtkada_Builder_Record'Class) is
      About : constant Gtk.Widget.Gtk_Widget :=
        Gtk.Widget.Gtk_Widget (Object.Get_Object ("about"));
   begin
      About.Hide;
   end On_Close_About;

end MAT.Callbacks;

Implement the On_Close_About procedure

Implement the On_Close_About procedure