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

with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
package body Util.Streams.Buffered is

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Output  : in Output_Stream_Access;
                         Input   : in Input_Stream_Access;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Output    := null;
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Input => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Buffered_Stream) is
   begin
      if Stream.Output /= null then
         Buffered_Stream'Class (Stream).Flush;
         Stream.Output.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Buffered_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Buffered_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write a raw character on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Char   : in Character) is
   begin
      if Stream.Write_Pos > Stream.Last then
         Stream.Flush;
         if Stream.Write_Pos > Stream.Last then
            raise Ada.IO_Exceptions.End_Error with "Buffer is full";
         end if;
      end if;
      Stream.Buffer (Stream.Write_Pos) := Stream_Element (Character'Pos (Char));
      Stream.Write_Pos := Stream.Write_Pos + 1;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in String) is
      Start : Positive := Item'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Natural;
      Size  : Natural;
      Char  : Character;
   begin
      while Start <= Item'Last loop
         Size := Item'Last - Start + 1;
         Avail := Natural (Stream.Last - Pos + 1);
         if Avail = 0 then
            Stream.Flush;
            Pos := Stream.Write_Pos;
            Avail := Natural (Stream.Last - Pos + 1);
            if Avail = 0 then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         while Size > 0 loop
            Char := Item (Start);
            Stream.Buffer (Pos) := Stream_Element (Character'Pos (Char));
            Pos := Pos + 1;
            Start := Start + 1;
            Size := Size - 1;
         end loop;
         Stream.Write_Pos := Pos;
      end loop;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String) is
      Count : constant Natural := Ada.Strings.Unbounded.Length (Item);
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            Stream.Write (Char => Ada.Strings.Unbounded.Element (Item, I));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Count : constant Natural := Ada.Strings.Wide_Wide_Unbounded.Length (Item);
      C     : Wide_Wide_Character;
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            C := Ada.Strings.Wide_Wide_Unbounded.Element (Item, I);
            Stream.Write (Char => Character'Val (Wide_Wide_Character'Pos (C)));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Buffered_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            Stream.Flush;
            Pos := Stream.Write_Pos;
            Avail := Stream.Last - Pos + 1;
            if Avail = 0 then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data that the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            Stream.Flush;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Buffered_Stream) is
   begin
      if Stream.Write_Pos > 1 and not Stream.No_Flush then
         if Stream.Output = null then
            raise Ada.IO_Exceptions.Data_Error with "Output buffer is full";
         else
            Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            Stream.Output.Flush;
         end if;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Buffered_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Buffered_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Buffered_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Buffered_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Buffered_Stream) is
   begin
      if Object.Buffer /= null then
         if Object.Output /= null then
            Object.Flush;
         end if;
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Buffered_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

end Util.Streams.Buffered;

-----------------------------------------------------------------------
--  Util.Streams.Buffered -- Buffered streams Stream utilities
--  Copyright (C) 2010, 2011, 2013, 2014, 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 Interfaces;
with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
package body Util.Streams.Buffered is

   procedure Free_Buffer is
     new Ada.Unchecked_Deallocation (Object => Stream_Element_Array,
                                     Name   => Buffer_Access);

   --  ------------------------------
   --  Initialize the stream to read or write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Output  : in Output_Stream_Access;
                         Input   : in Input_Stream_Access;
                         Size    : in Positive) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Size);
      Stream.Buffer    := new Stream_Element_Array (1 .. Stream.Last);
      Stream.Output    := Output;
      Stream.Input     := Input;
      Stream.Write_Pos := 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream to read from the string.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Content : in String) is
   begin
      Free_Buffer (Stream.Buffer);
      Stream.Last      := Stream_Element_Offset (Content'Length);
      Stream.Buffer    := new Stream_Element_Array (1 .. Content'Length);
      Stream.Output    := null;
      Stream.Input     := null;
      Stream.Write_Pos := Stream.Last + 1;
      Stream.Read_Pos  := 1;
      Stream.No_Flush  := False;
      for I in Content'Range loop
         Stream.Buffer (Stream_Element_Offset (I - Content'First + 1))
           := Character'Pos (Content (I));
      end loop;
   end Initialize;

   --  ------------------------------
   --  Initialize the stream with a buffer of Size bytes.
   --  ------------------------------
   procedure Initialize (Stream  : in out Buffered_Stream;
                         Size    : in Positive) is
   begin
      Stream.Initialize (Output => null, Input => null, Size => Size);
      Stream.No_Flush := True;
      Stream.Read_Pos := 1;
   end Initialize;

   --  ------------------------------
   --  Close the sink.
   --  ------------------------------
   overriding
   procedure Close (Stream : in out Buffered_Stream) is
   begin
      if Stream.Output /= null then
         Buffered_Stream'Class (Stream).Flush;
         Stream.Output.Close;
      end if;
   end Close;

   --  ------------------------------
   --  Get the direct access to the buffer.
   --  ------------------------------
   function Get_Buffer (Stream : in Buffered_Stream) return Buffer_Access is
   begin
      return Stream.Buffer;
   end Get_Buffer;

   --  ------------------------------
   --  Get the number of element in the stream.
   --  ------------------------------
   function Get_Size (Stream : in Buffered_Stream) return Natural is
   begin
      return Natural (Stream.Write_Pos - Stream.Read_Pos);
   end Get_Size;

   --  ------------------------------
   --  Write a raw character on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Char   : in Character) is
   begin
      if Stream.Write_Pos > Stream.Last then
         Stream.Flush;
         if Stream.Write_Pos > Stream.Last then
            raise Ada.IO_Exceptions.End_Error with "Buffer is full";
         end if;
      end if;
      Stream.Buffer (Stream.Write_Pos) := Stream_Element (Character'Pos (Char));
      Stream.Write_Pos := Stream.Write_Pos + 1;
   end Write;

   --  ------------------------------
   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   --  ------------------------------
   procedure Write_Wide (Stream : in out Buffered_Stream;
                         Item   : in Wide_Wide_Character) is
      use Interfaces;

      Val : Unsigned_32;
   begin
      --  UTF-8 conversion
      --  7  U+0000   U+007F   1  0xxxxxxx
      --  11 U+0080   U+07FF   2  110xxxxx 10xxxxxx
      --  16 U+0800   U+FFFF   3  1110xxxx 10xxxxxx 10xxxxxx
      --  21 U+10000  U+1FFFFF 4  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
      Val := Wide_Wide_Character'Pos (Item);
      if Val <= 16#7f# then
         Stream.Write (Character'Val (Val));
      elsif Val <= 16#07FF# then
         Stream.Write (Character'Val (16#C0# or Shift_Right (Val, 6)));
         Stream.Write (Character'Val (16#80# or (Val and 16#03F#)));
      elsif Val <= 16#0FFFF# then
         Stream.Write (Character'Val (16#E0# or Shift_Right (Val, 12)));
         Val := Val and 16#0FFF#;
         Stream.Write (Character'Val (16#80# or Shift_Right (Val, 6)));
         Stream.Write (Character'Val (16#80# or (Val and 16#03F#)));
      else
         Val := Val and 16#1FFFFF#;
         Stream.Write (Character'Val (16#F0# or Shift_Right (Val, 18)));
         Val := Val and 16#3FFFF#;
         Stream.Write (Character'Val (16#E0# or Shift_Right (Val, 12)));
         Val := Val and 16#0FFF#;
         Stream.Write (Character'Val (16#80# or Shift_Right (Val, 6)));
         Stream.Write (Character'Val (16#80# or (Val and 16#03F#)));
      end if;
   end Write_Wide;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in String) is
      Start : Positive := Item'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Natural;
      Size  : Natural;
      Char  : Character;
   begin
      while Start <= Item'Last loop
         Size := Item'Last - Start + 1;
         Avail := Natural (Stream.Last - Pos + 1);
         if Avail = 0 then
            Stream.Flush;
            Pos := Stream.Write_Pos;
            Avail := Natural (Stream.Last - Pos + 1);
            if Avail = 0 then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         while Size > 0 loop
            Char := Item (Start);
            Stream.Buffer (Pos) := Stream_Element (Character'Pos (Char));
            Pos := Pos + 1;
            Start := Start + 1;
            Size := Size - 1;
         end loop;
         Stream.Write_Pos := Pos;
      end loop;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String) is
      Count : constant Natural := Ada.Strings.Unbounded.Length (Item);
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            Stream.Write (Char => Ada.Strings.Unbounded.Element (Item, I));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Buffered_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Count : constant Natural := Ada.Strings.Wide_Wide_Unbounded.Length (Item);
      C     : Wide_Wide_Character;
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            C := Ada.Strings.Wide_Wide_Unbounded.Element (Item, I);
            Stream.Write (Char => Character'Val (Wide_Wide_Character'Pos (C)));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write the buffer array to the output stream.
   --  ------------------------------
   overriding
   procedure Write (Stream : in out Buffered_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      Start : Stream_Element_Offset := Buffer'First;
      Pos   : Stream_Element_Offset := Stream.Write_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
   begin
      while Start <= Buffer'Last loop
         Size := Buffer'Last - Start + 1;
         Avail := Stream.Last - Pos + 1;
         if Avail = 0 then
            Stream.Flush;
            Pos := Stream.Write_Pos;
            Avail := Stream.Last - Pos + 1;
            if Avail = 0 then
               raise Ada.IO_Exceptions.End_Error with "Buffer is full";
            end if;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Stream.Buffer (Pos .. Pos + Size - 1) := Buffer (Start .. Start + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Stream.Write_Pos := Pos;

         --  If we have still more data that the buffer size, flush and write
         --  the buffer directly.
         if Start < Buffer'Last and then Buffer'Last - Start > Stream.Buffer'Length then
            Stream.Flush;
            Stream.Output.Write (Buffer (Start .. Buffer'Last));
            return;
         end if;
      end loop;
   end Write;

   --  ------------------------------
   --  Flush the stream.
   --  ------------------------------
   overriding
   procedure Flush (Stream : in out Buffered_Stream) is
   begin
      if Stream.Write_Pos > 1 and not Stream.No_Flush then
         if Stream.Output = null then
            raise Ada.IO_Exceptions.Data_Error with "Output buffer is full";
         else
            Stream.Output.Write (Stream.Buffer (1 .. Stream.Write_Pos - 1));
            Stream.Output.Flush;
         end if;
         Stream.Write_Pos := 1;
      end if;
   end Flush;

   --  ------------------------------
   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   --  ------------------------------
   procedure Fill (Stream : in out Buffered_Stream) is
   begin
      if Stream.Input = null then
         Stream.Eof := True;
      else
         Stream.Input.Read (Stream.Buffer (1 .. Stream.Last - 1), Stream.Write_Pos);
         Stream.Eof := Stream.Write_Pos < 1;
         if not Stream.Eof then
            Stream.Write_Pos := Stream.Write_Pos + 1;
         end if;
         Stream.Read_Pos := 1;
      end if;
   end Fill;

   --  ------------------------------
   --  Read one character from the input stream.
   --  ------------------------------
   procedure Read (Stream : in out Buffered_Stream;
                   Char   : out Character) is
   begin
      if Stream.Read_Pos >= Stream.Write_Pos then
         Stream.Fill;
         if Stream.Eof then
            raise Ada.IO_Exceptions.Data_Error with "End of buffer";
         end if;
      end if;
      Char := Character'Val (Stream.Buffer (Stream.Read_Pos));
      Stream.Read_Pos := Stream.Read_Pos + 1;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Buffered_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
      Start : Stream_Element_Offset := Into'First;
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
      Size  : Stream_Element_Offset;
      Total : Stream_Element_Offset := 0;
   begin
      while Start <= Into'Last loop
         Size := Into'Last - Start + 1;
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            Pos := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
            exit when Avail <= 0;
         end if;
         if Avail < Size then
            Size := Avail;
         end if;
         Into (Start .. Start + Size - 1) := Stream.Buffer (Pos .. Pos + Size - 1);
         Start := Start + Size;
         Pos   := Pos + Size;
         Total := Total + Size;
         Stream.Read_Pos := Pos;
      end loop;
      Last := Total;
   end Read;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   procedure Read (Stream : in out Buffered_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String) is
      Pos   : Stream_Element_Offset := Stream.Read_Pos;
      Avail : Stream_Element_Offset;
   begin
      loop
         Avail := Stream.Write_Pos - Pos;
         if Avail = 0 then
            Stream.Fill;
            if Stream.Eof then
               return;
            end if;
            Pos   := Stream.Read_Pos;
            Avail := Stream.Write_Pos - Pos;
         end if;
         for I in 1 .. Avail loop
            Ada.Strings.Unbounded.Append (Into, Character'Val (Stream.Buffer (Pos)));
            Pos := Pos + 1;
         end loop;
         Stream.Read_Pos := Pos;
      end loop;
   end Read;

   --  ------------------------------
   --  Flush the stream and release the buffer.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Buffered_Stream) is
   begin
      if Object.Buffer /= null then
         if Object.Output /= null then
            Object.Flush;
         end if;
         Free_Buffer (Object.Buffer);
      end if;
   end Finalize;

   --  ------------------------------
   --  Returns True if the end of the stream is reached.
   --  ------------------------------
   function Is_Eof (Stream : in Buffered_Stream) return Boolean is
   begin
      return Stream.Eof;
   end Is_Eof;

end Util.Streams.Buffered;

Implement the Write_Wide procedure with UTF-8 conversion


-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2016, 2017, 2019, 2020, 2021, 2022 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.IO_Exceptions;
package body Util.Streams.Texts is

   use Ada.Streams;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : access Output_Stream'Class) is
   begin
      Stream.Initialize (Output => To, Size => 4096);
   end Initialize;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String) is
      Count : constant Natural := Ada.Strings.Unbounded.Length (Item);
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            Stream.Write (Item => Ada.Strings.Unbounded.Element (Item, I));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Count : constant Natural := Ada.Strings.Wide_Wide_Unbounded.Length (Item);
      C     : Wide_Wide_Character;
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            C := Ada.Strings.Wide_Wide_Unbounded.Element (Item, I);
            Stream.Write_Wide (C);
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write an integer on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer) is
      S : constant String := Integer'Image (Item);
   begin
      if Item >= 0 then
         Stream.Write (S (S'First + 1 .. S'Last));
      else
         Stream.Write (S);
      end if;
   end Write;

   --  ------------------------------
   --  Write an integer on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer) is
      S : constant String := Long_Long_Integer'Image (Item);
   begin
      if Item >= 0 then
         Stream.Write (S (S'First + 1 .. S'Last));
      else
         Stream.Write (S);
      end if;
   end Write;

   --  ------------------------------
   --  Write a date on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date) is
   begin
      Stream.Write (GNAT.Calendar.Time_IO.Image (Item, Format));
   end Write;

   --  ------------------------------
   --  Get the output stream content as a string.
   --  ------------------------------
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String is
      Size   : constant Natural := Stream.Get_Size;
      Buffer : constant Streams.Buffered.Buffer_Access := Stream.Get_Buffer;
      Result : String (1 .. Size);
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Buffer (Stream_Element_Offset (I)));
      end loop;
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a character on the stream.
   --  ------------------------------
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character) is
   begin
      Stream.Write (Item);
   end Write_Char;

   --  ------------------------------
   --  Write a character on the stream.
   --  ------------------------------
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character) is
   begin
      Stream.Write_Wide (Item);
   end Write_Char;

   --  ------------------------------
   --  Initialize the reader to read the input from the input stream given in From.
   --  ------------------------------
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : access Input_Stream'Class) is
   begin
      Stream.Initialize (Input => From, Size => 4096);
   end Initialize;

   --  ------------------------------
   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   --  ------------------------------
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False) is
      C : Character;
   begin
      while not Stream.Is_Eof loop
         Stream.Read (C);
         if C = ASCII.LF then
            if not Strip then
               Ada.Strings.Unbounded.Append (Into, C);
            end if;
            return;
         elsif C /= ASCII.CR or not Strip then
            Ada.Strings.Unbounded.Append (Into, C);
         end if;
      end loop;

   exception
      when Ada.IO_Exceptions.Data_Error
        | Ada.IO_Exceptions.Device_Error
        | Ada.Io_Exceptions.End_Error =>
         return;
   end Read_Line;

end Util.Streams.Texts;

-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2016, 2017, 2019, 2020, 2021, 2022 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.IO_Exceptions;
package body Util.Streams.Texts is

   use Ada.Streams;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : access Output_Stream'Class) is
   begin
      Stream.Initialize (Output => To, Size => 4096);
   end Initialize;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String) is
      Count : constant Natural := Ada.Strings.Unbounded.Length (Item);
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            Stream.Write (Item => Ada.Strings.Unbounded.Element (Item, I));
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write a raw string on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) is
      Count : constant Natural := Ada.Strings.Wide_Wide_Unbounded.Length (Item);
      C     : Wide_Wide_Character;
   begin
      if Count > 0 then
         for I in 1 .. Count loop
            C := Ada.Strings.Wide_Wide_Unbounded.Element (Item, I);
            Stream.Write_Wide (C);
         end loop;
      end if;
   end Write;

   --  ------------------------------
   --  Write an integer on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer) is
      S : constant String := Integer'Image (Item);
   begin
      if Item >= 0 then
         Stream.Write (S (S'First + 1 .. S'Last));
      else
         Stream.Write (S);
      end if;
   end Write;

   --  ------------------------------
   --  Write an integer on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer) is
      S : constant String := Long_Long_Integer'Image (Item);
   begin
      if Item >= 0 then
         Stream.Write (S (S'First + 1 .. S'Last));
      else
         Stream.Write (S);
      end if;
   end Write;

   --  ------------------------------
   --  Write a date on the stream.
   --  ------------------------------
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date) is
   begin
      Stream.Write (GNAT.Calendar.Time_IO.Image (Item, Format));
   end Write;

   --  ------------------------------
   --  Get the output stream content as a string.
   --  ------------------------------
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String is
      Size   : constant Natural := Stream.Get_Size;
      Buffer : constant Streams.Buffered.Buffer_Access := Stream.Get_Buffer;
      Result : String (1 .. Size);
   begin
      for I in Result'Range loop
         Result (I) := Character'Val (Buffer (Stream_Element_Offset (I)));
      end loop;
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a character on the stream.
   --  ------------------------------
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character) is
   begin
      Stream.Write (Item);
   end Write_Char;

   --  ------------------------------
   --  Write a character on the stream.
   --  ------------------------------
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character) is
   begin
      Stream.Write_Wide (Item);
   end Write_Char;

   --  ------------------------------
   --  Initialize the reader to read the input from the input stream given in From.
   --  ------------------------------
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : access Input_Stream'Class) is
   begin
      Stream.Initialize (Input => From, Size => 4096);
   end Initialize;

   --  ------------------------------
   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   --  ------------------------------
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False) is
      C : Character;
   begin
      while not Stream.Is_Eof loop
         Stream.Read (C);
         if C = ASCII.LF then
            if not Strip then
               Ada.Strings.Unbounded.Append (Into, C);
            end if;
            return;
         elsif C /= ASCII.CR or not Strip then
            Ada.Strings.Unbounded.Append (Into, C);
         end if;
      end loop;

   exception
      when Ada.IO_Exceptions.Data_Error
        | Ada.IO_Exceptions.Device_Error
        | Ada.IO_Exceptions.End_Error =>
         return;
   end Read_Line;

end Util.Streams.Texts;

Fix style name in exception

Fix style name in exception


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

with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Calendar;
with Ada.Containers.Indefinite_Vectors;

with ADO.Utils;
with ADO.Drivers.Dialects;

--  == Query Parameters ==
--  Query parameters are represented by the <tt>Parameter</tt> type which can represent almost
--  all database types including boolean, numbers, strings, dates and blob.  Parameters are
--  put in a list represented by the <tt>Abstract_List</tt> or <tt>List</tt> types.
--
--  A parameter is added by using either the <tt>Bind_Param</tt> or the <tt>Add_Param</tt>
--  operation.  The <tt>Bind_Param</tt> operation allows to specify either the parameter name
--  or its position.  The <tt>Add_Param</tt> operation adds the parameter at end of the list
--  and uses the last position.  In most cases, it is easier to bind a parameter with a name
--  as follows:
--
--    Query.Bind_Param ("name", "Joe");
--
--  and the SQL can use the following construct:
--
--    SELECT * FROM user WHERE name = :name
--
--  When the <tt>Add_Param</tt> is used, the parameter is not associated with any name but it
--  as a position index.  Setting a parameter is easier:
--
--    Query.Add_Param ("Joe");
--
--  but the SQL cannot make any reference to names and must use the <tt>?</tt> construct:
--
--    SELECT * FROM user WHERE name = ?
--
--  === Parameter Expander ===
--  The parameter expander is a mechanism that allows to replace or inject values in the SQL
--  query by looking at an operation provided by the <tt>Expander</tt> interface.  Such expander
--  is useful to replace parameters that are global to a session or to an application.
--
package ADO.Parameters is

   use Ada.Strings.Unbounded;

   type Token is new String;

   type Parameter_Type is (T_NULL, T_STRING, T_TOKEN, T_LIST, T_DATE, T_LONG_INTEGER,
                           T_INTEGER, T_BOOLEAN, T_BLOB);

   type Parameter (T   : Parameter_Type;
                   Len : Natural;
                   Value_Len : Natural) is record
      Position : Natural := 0;
      Name     : String (1 .. Len);
      case T is
         when T_NULL =>
            null;

         when T_LONG_INTEGER =>
            Long_Num : Long_Long_Integer := 0;

         when T_INTEGER =>
            Num : Integer;

         when T_BOOLEAN =>
            Bool : Boolean;

         when T_DATE =>
            Time : Ada.Calendar.Time;

         when T_BLOB =>
            Data : ADO.Blob_Ref;

         when others =>
            Str : String (1 .. Value_Len);
      end case;
   end record;

   type Expander is limited interface;
   type Expander_Access is access all Expander'Class;

   --  Expand the name from the given group into a target parameter value to be used in
   --  the SQL query.  The expander can look in a cache or in some configuration to find
   --  the value associated with the name and return it.  The Expander can return a
   --  T_NULL when a value is not found or it may also raise some exception.
   function Expand (Instance : in Expander;
                    Group    : in String;
                    Name     : in String) return Parameter is abstract;

   type Abstract_List is abstract new Ada.Finalization.Controlled with private;
   type Abstract_List_Access is access all Abstract_List'Class;

   --  Set the SQL dialect description object.
   procedure Set_Dialect (Params : in out Abstract_List;
                          D      : in ADO.Drivers.Dialects.Dialect_Access);

   --  Set the cache expander to be used when expanding the SQL.
   procedure Set_Expander (Params   : in out Abstract_List;
                           Expander : in ADO.Parameters.Expander_Access);

   --  Get the SQL dialect description object.
   function Get_Dialect (From : in Abstract_List) return ADO.Drivers.Dialects.Dialect_Access;

   --  Add the parameter in the list.
   procedure Add_Parameter (Params : in out Abstract_List;
                            Param  : in Parameter) is abstract;

   --  Set the parameters from another parameter list.
   procedure Set_Parameters (Parameters : in out Abstract_List;
                             From       : in Abstract_List'Class) is abstract;

   --  Return the number of parameters in the list.
   function Length (Params : in Abstract_List) return Natural is abstract;

   --  Return the parameter at the given position
   function Element (Params   : in Abstract_List;
                     Position : in Natural) return Parameter is abstract;

   --  Execute the Process procedure with the given parameter as argument.
   procedure Query_Element (Params   : in Abstract_List;
                            Position : in Natural;
                            Process  : not null access
                              procedure (Element : in Parameter)) is abstract;

   --  Clear the list of parameters.
   procedure Clear (Parameters : in out Abstract_List) is abstract;

   --  Operations to bind a parameter
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Boolean);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Long_Long_Integer);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Identifier);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Integer);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in ADO.Entity_Type);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in String);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Unbounded_String);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Ada.Calendar.Time);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in Token);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in ADO.Blob_Ref);
   procedure Bind_Param (Params : in out Abstract_List;
                         Name   : in String;
                         Value  : in ADO.Utils.Identifier_Vector);

   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Boolean);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Long_Long_Integer);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Identifier);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Integer);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Entity_Type);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in String);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Unbounded_String);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in Ada.Calendar.Time);
   procedure Bind_Param (Params   : in out Abstract_List;
                         Position : in Natural;
                         Value    : in ADO.Blob_Ref);
   procedure Bind_Null_Param (Params   : in out Abstract_List;
                              Position : in Natural);
   procedure Bind_Null_Param (Params   : in out Abstract_List;
                              Name     : in String);

   procedure Add_Param (Params : in out Abstract_List;
                         Value : in Boolean);
   procedure Add_Param (Params : in out Abstract_List;
                         Value : in Long_Long_Integer);
   procedure Add_Param (Params : in out Abstract_List;
                         Value : in Identifier);
   procedure Add_Param (Params : in out Abstract_List;
                         Value : in Integer);
   procedure Add_Param (Params : in out Abstract_List;
                         Value : in String);
   procedure Add_Param (Params : in out Abstract_List;
                         Value : in Unbounded_String);
   procedure Add_Param (Params : in out Abstract_List;
                        Value : in Ada.Calendar.Time);

   --  Add a null parameter.
   procedure Add_Null_Param (Params : in out Abstract_List);

   --  Expand the SQL string with the query parameters.  The following parameters syntax
   --  are recognized and replaced:
   --

   --
? is replaced according to the current parameter index.  The index is incremented
   --         after each occurrence of ? character.
   --
:nnn is replaced by the parameter at index nnn.
   --
:name is replaced by the parameter with the name name
   --
$group[var-name] is replaced by using the expander interface.
   --

   --  Parameter strings are escaped.  When a parameter is not found, an empty string is used.
   --  Returns the expanded SQL string.
   function Expand (Params : in Abstract_List'Class;
                    SQL    : in String) return String;

   --  ------------------------------
   --  List of parameters
   --  ------------------------------
   --  The List is an implementation of the parameter list.
   type List is new Abstract_List with private;

   procedure Add_Parameter (Params : in out List;
                            Param  : in Parameter);

   procedure Set_Parameters (Params : in out List;
                             From   : in Abstract_List'Class);

   --  Return the number of parameters in the list.
   function Length (Params : in List) return Natural;

   --  Return the parameter at the given position
   function Element (Params   : in List;
                     Position : in Natural) return Parameter;

   --  Execute the Process procedure with the given parameter as argument.
   procedure Query_Element (Params   : in List;
                            Position : in Natural;
                            Process  : not null access procedure (Element : in Parameter));

   --  Clear the list of parameters.
   procedure Clear (Params : in out List);

private

   function Compare_On_Name (Left, Right : in Parameter) return Boolean;

   package Parameter_Vectors is
     new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                            Element_Type => Parameter,
                                            "="          => Compare_On_Name);

   type Abstract_List is abstract new Ada.Finalization.Controlled with record
      Dialect  : ADO.Drivers.Dialects.Dialect_Access := null;
      Expander : Expander_Access;
   end record;

   type List is new Abstract_List with record
      Params : Parameter_Vectors.Vector;
   end record;

end ADO.Parameters;

Fix style warning reported by GNAT 2018

Fix style warning reported by GNAT 2018


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

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

   --  ------------------------------
   --  Get an element instance from the pool.
   --  Wait until one instance gets available.
   --  ------------------------------
   procedure Get_Instance (From : in out Pool;
                           Item : out Element_Type) is
   begin
      From.List.Get_Instance (Item);
   end Get_Instance;

   --  ------------------------------
   --  Put the element back to the pool.
   --  ------------------------------
   procedure Release (Into : in out Pool;
                      Item : in Element_Type) is
   begin
      Into.List.Release (Item);
   end Release;

   --  ------------------------------
   --  Set the pool size.
   --  ------------------------------
   procedure Set_Size (Into : in out Pool;
                       Capacity : in Positive) is
   begin
      Into.List.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Release the pool elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Pool) is
   begin
      Object.List.Set_Size (0);
   end Finalize;

   --  Pool of objects
   protected body Protected_Pool is

      --  ------------------------------
      --  Get an element instance from the pool.
      --  Wait until one instance gets available.
      --  ------------------------------
      entry Get_Instance (Item : out Element_Type) when Available > 0 is
      begin
         Item := Elements (Available);
         Available := Available - 1;
      end Get_Instance;

      --  ------------------------------
      --  Put the element back to the pool.
      --  ------------------------------
      procedure Release (Item : in Element_Type) is
      begin
         Available := Available + 1;
         Elements (Available) := Item;
      end Release;

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

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

   end Protected_Pool;

end Util.Concurrent.Pools;

-----------------------------------------------------------------------
--  Util.Concurrent.Pools -- Concurrent Pools
--  Copyright (C) 2011, 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.Unchecked_Deallocation;
package body Util.Concurrent.Pools is

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

   --  ------------------------------
   --  Put the element back to the pool.
   --  ------------------------------
   procedure Release (Into : in out Pool;
                      Item : in Element_Type) is
   begin
      Into.List.Release (Item);
   end Release;

   --  ------------------------------
   --  Set the pool size.
   --  ------------------------------
   procedure Set_Size (Into : in out Pool;
                       Capacity : in Positive) is
   begin
      Into.List.Set_Size (Capacity);
   end Set_Size;

   --  ------------------------------
   --  Release the pool elements.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Pool) is
   begin
      Object.List.Set_Size (0);
   end Finalize;

   --  Pool of objects
   protected body Protected_Pool is

      --  ------------------------------
      --  Get an element instance from the pool.
      --  Wait until one instance gets available.
      --  ------------------------------
      entry Get_Instance (Item : out Element_Type) when Available > 0 is
      begin
         Item := Elements (Available);
         Available := Available - 1;
      end Get_Instance;

      --  ------------------------------
      --  Put the element back to the pool.
      --  ------------------------------
      procedure Release (Item : in Element_Type) is
      begin
         Available := Available + 1;
         Elements (Available) := Item;
      end Release;

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

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

   end Protected_Pool;

end Util.Concurrent.Pools;

Add the Wait parameter to Get_Instance and raise the Timeout exception if no object from the pool was available before the delay expired


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

with Util.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character);

   --  Enable or disable the double quotes by default for strings.
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean);

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

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

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
      Separator   : Character := ',';
      Quote       : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
   end record;

end Util.Serialize.IO.CSV;

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

with Util.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Stream    : in out Output_Stream;
                                  Separator : in Character);

   --  Enable or disable the double quotes by default for strings.
   procedure Set_Quotes (Stream : in out Output_Stream;
                         Enable : in Boolean);

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
      Separator   : Character := ',';
      Quote       : Boolean := True;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
      Sink        : access Reader'Class;
   end record;

end Util.Serialize.IO.CSV;

Add a Sink parameter to the Parse procedure


-----------------------------------------------------------------------
--  awa-users-principals -- User principals
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body AWA.Users.Principals is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Name;

   --  ------------------------------
   --  Get the principal identifier (name)
   --  ------------------------------
   function Get_Id (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Id;

   --  ------------------------------
   --  Get the user associated with the principal.
   --  ------------------------------
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref is
   begin
      return From.User;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.User.Get_Id;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the connection session used by the user.
   --  ------------------------------
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref is
   begin
      return From.Session;
   end Get_Session;

   --  ------------------------------
   --  Get the connection session identifier used by the user.
   --  ------------------------------
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.Session.Get_Id;
   end Get_Session_Identifier;

   --  ------------------------------
   --  Create a principal for the given user.
   --  ------------------------------
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access is
      Result : constant Principal_Access := new Principal;
   begin
      Result.User    := User;
      Result.Session := Session;
      return Result;
   end Create;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   --  ------------------------------
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier is
      use type ASF.Principals.Principal_Access;
   begin
      if From = null then
         return ADO.NO_IDENTIFIER;

      elsif not (From.all in Principal'Class) then
         return ADO.NO_IDENTIFIER;

      else
         return Principal'Class (From.all).Get_User_Identifier;
      end if;
   end Get_User_Identifier;

end AWA.Users.Principals;

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

package body AWA.Users.Principals is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Name;

   --  ------------------------------
   --  Get the principal identifier (name)
   --  ------------------------------
   function Get_Id (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Id;

   --  ------------------------------
   --  Get the user associated with the principal.
   --  ------------------------------
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref is
   begin
      return From.User;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.User.Get_Id;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the connection session used by the user.
   --  ------------------------------
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref is
   begin
      return From.Session;
   end Get_Session;

   --  ------------------------------
   --  Get the connection session identifier used by the user.
   --  ------------------------------
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.Session.Get_Id;
   end Get_Session_Identifier;

   --  ------------------------------
   --  Create a principal for the given user.
   --  ------------------------------
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access is
      Result : constant Principal_Access := new Principal;
   begin
      Result.User    := User;
      Result.Session := Session;
      return Result;
   end Create;

   --  ------------------------------
   --  Create a principal for the given user.
   --  ------------------------------
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal is
   begin
      return Result : Principal do
         Result.User    := User;
         Result.Session := Session;
      end return;
   end Create;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   --  ------------------------------
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier is
      use type ASF.Principals.Principal_Access;
   begin
      if From = null then
         return ADO.NO_IDENTIFIER;

      elsif not (From.all in Principal'Class) then
         return ADO.NO_IDENTIFIER;

      else
         return Principal'Class (From.all).Get_User_Identifier;
      end if;
   end Get_User_Identifier;

end AWA.Users.Principals;

Implement the new Create operation to build a principal from a user/session


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

package Druss.Commands.Devices is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Devices;

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

package Druss.Commands.Devices is

   type Command_Type is new Druss.Commands.Drivers.Command_Type with null record;

   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Selector  : in Device_Selector_Type;
                      Context   : in out Context_Type);

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type);

end Druss.Commands.Devices;

Add a device selector to the Do_List procedure


-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  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.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with AWA.Events;
with AWA.Workspaces.Modules;
package AWA.Workspaces.Beans is

   type Workspaces_Bean is new Util.Beans.Basic.Bean
     and Util.Beans.Methods.Method_Bean with record
      Module : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Count  : Natural := 0;
   end record;
   type Workspaces_Bean_Access is access all Workspaces_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Event action called to create the workspace when the given event is posted.
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class);

   --  Example of action method.
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Workspaces_Bean bean instance.
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Workspaces.Beans;

-----------------------------------------------------------------------
--  awa-workspaces-beans -- Beans for module workspaces
--  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.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with AWA.Events;
with AWA.Workspaces.Models;
with AWA.Workspaces.Modules;
package AWA.Workspaces.Beans is

   type Invitation_Bean is new AWA.Workspaces.Models.Invitation_Bean with record
      Module : AWA.Workspaces.Modules.Workspace_Module_Access := null;
   end record;
   type Invitation_Bean_Access is access all Invitation_Bean'Class;

   overriding
   procedure Load (Bean : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Accept_Invitation (Bean    : in out Invitation_Bean;
                                Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   overriding
   procedure Send (Bean    : in out Invitation_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Workspaces_Bean is new Util.Beans.Basic.Bean
     and Util.Beans.Methods.Method_Bean with record
      Module : AWA.Workspaces.Modules.Workspace_Module_Access := null;
      Count  : Natural := 0;
   end record;
   type Workspaces_Bean_Access is access all Workspaces_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Workspaces_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Workspaces_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Workspaces_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Event action called to create the workspace when the given event is posted.
   procedure Create (Bean  : in out Workspaces_Bean;
                     Event : in AWA.Events.Module_Event'Class);

   --  Example of action method.
   procedure Action (Bean    : in out Workspaces_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Workspaces_Bean bean instance.
   function Create_Workspaces_Bean (Module : in AWA.Workspaces.Modules.Workspace_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Workspaces.Beans;

Declare the Invitation_Bean with the Load, Send and Accept_Invitation procedures