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

-----------------------------------------------------------------------
--  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#80# 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;

Fix UTF-8 4-byte sequence

Fix UTF-8 4-byte sequence


-----------------------------------------------------------------------
--  druss-commands-ping -- Ping devices from the gateway
--  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.Ping is

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

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

   --  Execute a ping from the gateway to each device.
   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.Ping;

-----------------------------------------------------------------------
--  druss-commands-ping -- Ping devices from the gateway
--  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.Ping is

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

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

   --  Execute a ping from the gateway to each device.
   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.Ping;

Add a device selector to the Do_Ping procedure


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

with AWA.Storages.Models;
with AWA.Storages.Modules;

with ASF.Parts;

with ADO;

with Util.Beans.Objects;
with Util.Beans.Basic;
package AWA.Storages.Beans is

   FOLDER_ID_PARAMETER : constant String := "folderId";

   --  ------------------------------
   --  Upload Bean
   --  ------------------------------
   --  The Upload_Bean allows to upload a file in the storage space.
   type Upload_Bean is new AWA.Storages.Models.Upload_Bean with record
      Module    : AWA.Storages.Modules.Storage_Module_Access := null;
      Folder_Id : ADO.Identifier;
   end record;
   type Upload_Bean_Access is access all Upload_Bean'Class;

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

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

   --  Save the uploaded file in the storage service.
   --  @method
   procedure Save_Part (Bean : in out Upload_Bean;
                        Part : in ASF.Parts.Part'Class);

   --  Upload the file.
   overriding
   procedure Upload (Bean    : in out Upload_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the file.
   overriding
   procedure Delete (Bean    : in out Upload_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Publish the file.
   overriding
   procedure Publish (Bean    : in out Upload_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Upload_Bean bean instance.
   function Create_Upload_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Folder Bean
   --  ------------------------------
   --  The Folder_Bean allows to create or update the folder name.
   type Folder_Bean is new AWA.Storages.Models.Storage_Folder_Ref
     and Util.Beans.Basic.Bean with record
      Module  : AWA.Storages.Modules.Storage_Module_Access := null;
   end record;
   type Folder_Bean_Access is access all Folder_Bean'Class;

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

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

   --  Create or save the folder.
   procedure Save (Bean    : in out Folder_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Init_Flag is (INIT_FOLDER, INIT_FOLDER_LIST, INIT_FILE_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Storage List Bean
   --  ------------------------------
   --  This bean represents a list of storage files for a given folder.
   type Storage_List_Bean is new Util.Beans.Basic.Bean with record
      Module           : AWA.Storages.Modules.Storage_Module_Access := null;

      --  Current folder.
      Folder           : aliased Folder_Bean;
      Folder_Bean      : Folder_Bean_Access;

      --  List of folders.
      Folder_List      : aliased AWA.Storages.Models.Folder_Info_List_Bean;
      Folder_List_Bean : AWA.Storages.Models.Folder_Info_List_Bean_Access;

      --  List of files.
      Files_List       : aliased AWA.Storages.Models.Storage_Info_List_Bean;
      Files_List_Bean  : AWA.Storages.Models.Storage_Info_List_Bean_Access;

      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Storage_List_Bean_Access is access all Storage_List_Bean'Class;

   --  Load the folder instance.
   procedure Load_Folder (Storage : in Storage_List_Bean);

   --  Load the list of folders.
   procedure Load_Folders (Storage : in Storage_List_Bean);

   --  Load the list of files associated with the current folder.
   procedure Load_Files (Storage : in Storage_List_Bean);

   overriding
   function Get_Value (List : in Storage_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

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

   --  Create the Folder_List_Bean bean instance.
   function Create_Folder_List_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Storage_List_Bean bean instance.
   function Create_Storage_List_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Storages.Beans;

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

with AWA.Storages.Models;
with AWA.Storages.Modules;

with ASF.Parts;

with ADO;

with Util.Beans.Objects;
with Util.Beans.Basic;
package AWA.Storages.Beans is

   FOLDER_ID_PARAMETER : constant String := "folderId";

   --  ------------------------------
   --  Upload Bean
   --  ------------------------------
   --  The Upload_Bean allows to upload a file in the storage space.
   type Upload_Bean is new AWA.Storages.Models.Upload_Bean with record
      Module    : AWA.Storages.Modules.Storage_Module_Access := null;
      Folder_Id : ADO.Identifier;
   end record;
   type Upload_Bean_Access is access all Upload_Bean'Class;

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

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

   --  Save the uploaded file in the storage service.
   --  @method
   procedure Save_Part (Bean : in out Upload_Bean;
                        Part : in ASF.Parts.Part'Class);

   --  Upload the file.
   overriding
   procedure Upload (Bean    : in out Upload_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete the file.
   overriding
   procedure Delete (Bean    : in out Upload_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Publish the file.
   overriding
   procedure Publish (Bean    : in out Upload_Bean;
                      Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Upload_Bean bean instance.
   function Create_Upload_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

   --  ------------------------------
   --  Folder Bean
   --  ------------------------------
   --  The Folder_Bean allows to create or update the folder name.
   type Folder_Bean is new AWA.Storages.Models.Storage_Folder_Ref
     and Util.Beans.Basic.Bean with record
      Module  : AWA.Storages.Modules.Storage_Module_Access := null;
   end record;
   type Folder_Bean_Access is access all Folder_Bean'Class;

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

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

   --  Create or save the folder.
   procedure Save (Bean    : in out Folder_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Init_Flag is (INIT_FOLDER, INIT_FOLDER_LIST, INIT_FILE_LIST);
   type Init_Map is array (Init_Flag) of Boolean;

   --  ------------------------------
   --  Storage List Bean
   --  ------------------------------
   --  This bean represents a list of storage files for a given folder.
   type Storage_List_Bean is new AWA.Storages.Models.Storage_List_Bean with record
      Module           : AWA.Storages.Modules.Storage_Module_Access := null;

      --  Current folder.
      Folder           : aliased Folder_Bean;
      Folder_Bean      : Folder_Bean_Access;

      --  List of folders.
      Folder_List      : aliased AWA.Storages.Models.Folder_Info_List_Bean;
      Folder_List_Bean : AWA.Storages.Models.Folder_Info_List_Bean_Access;

      --  List of files.
      Files_List       : aliased AWA.Storages.Models.Storage_Info_List_Bean;
      Files_List_Bean  : AWA.Storages.Models.Storage_Info_List_Bean_Access;

      Init_Flags       : aliased Init_Map := (others => False);
      Flags            : access Init_Map;
   end record;
   type Storage_List_Bean_Access is access all Storage_List_Bean'Class;

   --  Load the folder instance.
   procedure Load_Folder (Storage : in Storage_List_Bean);

   --  Load the list of folders.
   procedure Load_Folders (Storage : in Storage_List_Bean);

   --  Load the list of files associated with the current folder.
   procedure Load_Files (Storage : in Storage_List_Bean);

   overriding
   function Get_Value (List : in Storage_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

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

   --  Load the files and folder information.
   overriding
   procedure Load (List    : in out Storage_List_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Folder_List_Bean bean instance.
   function Create_Folder_List_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                     return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Storage_List_Bean bean instance.
   function Create_Storage_List_Bean (Module : in AWA.Storages.Modules.Storage_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Storages.Beans;

Use the UML AWA.Storages.Models.Storage_List_Bean type and override the Load procedure


--  Copyright (c) 2015 onox <denkpadje@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 Orka.Programs.Modules;
with Orka.Programs.Uniforms;

package body Orka.Programs is

   package Program_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Program);

   Current_Program : Program_Holder.Holder;

   function Create_Program (Modules   : Programs.Modules.Module_Array;
                            Separable : Boolean := False) return Program is
      use type GL.Types.Int;
   begin
      return Result : Program do
         --  Attach all shaders to the program before linking
         Programs.Modules.Attach_Shaders (Modules, Result);

         Result.GL_Program.Link;
         if not Result.GL_Program.Link_Status then
            raise Program_Link_Error with Result.GL_Program.Info_Log;
         end if;

         --  Construct arrays of subroutine indices per shader kind
         Result.Has_Subroutines := False;
         Result.Subroutines_Modified := False;
         for Shader_Kind in Programs.Modules.Non_Compute_Shader_Type loop
            declare
               Locations : constant GL.Types.Size
                 := Result.GL_Program.Subroutine_Uniform_Locations (Shader_Kind);
               subtype Indices_Array is GL.Types.UInt_Array (0 .. Locations - 1);
            begin
               if Indices_Array'Length > 0 then
                  Result.Has_Subroutines := True;
               end if;
               Result.Subroutines (Shader_Kind)
                 := Subroutines_Holder.To_Holder (Indices_Array'(others => GL.Types.UInt'Last));
            end;
         end loop;
      end return;
   end Create_Program;

   function Create_Program (Module    : Programs.Modules.Module;
                            Separable : Boolean := False) return Program is
   begin
      return Create_Program (Modules.Module_Array'(1 => Module));
   end Create_Program;

   function GL_Program (Object : Program) return GL.Objects.Programs.Program
     is (Object.GL_Program);

   function Has_Subroutines (Object : Program) return Boolean
     is (Object.Has_Subroutines);

   procedure Use_Subroutines (Object : in out Program) is
   begin
      for Shader_Kind in Programs.Modules.Non_Compute_Shader_Type loop
         declare
            Indices : GL.Types.UInt_Array renames Object.Subroutines (Shader_Kind).Element;
         begin
            if Indices'Length > 0 then
               GL.Objects.Programs.Set_Uniform_Subroutines (Shader_Kind, Indices);
            end if;
         end;
      end loop;
      Object.Subroutines_Modified := False;
   end Use_Subroutines;

   procedure Use_Program (Object : in out Program) is
   begin
      if Current_Program.Is_Empty or else Object /= Current_Program.Element then
         Object.GL_Program.Use_Program;
         Current_Program.Replace_Element (Object);
         if Object.Has_Subroutines then
            Object.Use_Subroutines;
         end if;
      elsif Object.Subroutines_Modified then
         Object.Use_Subroutines;
      end if;
   end Use_Program;

   function Attribute_Location (Object : Program; Name : String)
      return GL.Attributes.Attribute is
   begin
      return Object.GL_Program.Attrib_Location (Name);
   end Attribute_Location;

   procedure Set_Subroutine_Function
     (Object   : in out Program;
      Shader   : GL.Objects.Shaders.Shader_Type;
      Location : Uniform_Location;
      Index    : Subroutine_Index)
   is
      procedure Set_Index (Indices : in out GL.Types.UInt_Array) is
      begin
         Indices (Location) := Index;
      end Set_Index;
   begin
      Object.Subroutines (Shader).Update_Element (Set_Index'Access);
      Object.Subroutines_Modified := True;
   end Set_Subroutine_Function;

   function Uniform_Sampler (Object : Program; Name : String)
     return Uniforms.Uniform_Sampler is
   begin
      return Uniforms.Create_Uniform_Sampler (Object, Name);
   end Uniform_Sampler;

   function Uniform_Image (Object : Program; Name : String)
     return Uniforms.Uniform_Image is
   begin
      return Uniforms.Create_Uniform_Image (Object, Name);
   end Uniform_Image;

   function Uniform_Subroutine
     (Object : in out Program;
      Shader : GL.Objects.Shaders.Shader_Type;
      Name   : String) return Uniforms.Uniform_Subroutine is
   begin
      return Uniforms.Create_Uniform_Subroutine (Object, Shader, Name);
   end Uniform_Subroutine;

   function Uniform_Block (Object : Program; Name : String)
     return Uniforms.Uniform_Block is
   begin
      return Uniforms.Create_Uniform_Block (Object, Name);
   end Uniform_Block;

   function Uniform (Object : Program; Name : String)
     return Uniforms.Uniform is
   begin
      return Uniforms.Create_Uniform_Variable (Object, Name);
   end Uniform;

end Orka.Programs;

--  Copyright (c) 2015 onox <denkpadje@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 Orka.Programs.Modules;
with Orka.Programs.Uniforms;

package body Orka.Programs is

   package Program_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Program);

   Current_Program : Program_Holder.Holder;

   function Create_Program (Modules   : Programs.Modules.Module_Array;
                            Separable : Boolean := False) return Program is
      use type GL.Types.Int;
   begin
      return Result : Program do
         --  Attach all shaders to the program before linking
         Programs.Modules.Attach_Shaders (Modules, Result);

         Result.GL_Program.Set_Separable (Separable);

         Result.GL_Program.Link;
         if not Result.GL_Program.Link_Status then
            raise Program_Link_Error with Result.GL_Program.Info_Log;
         end if;

         --  Construct arrays of subroutine indices per shader kind
         Result.Has_Subroutines := False;
         Result.Subroutines_Modified := False;
         for Shader_Kind in Programs.Modules.Non_Compute_Shader_Type loop
            declare
               Locations : constant GL.Types.Size
                 := Result.GL_Program.Subroutine_Uniform_Locations (Shader_Kind);
               subtype Indices_Array is GL.Types.UInt_Array (0 .. Locations - 1);
            begin
               if Indices_Array'Length > 0 then
                  Result.Has_Subroutines := True;
               end if;
               Result.Subroutines (Shader_Kind)
                 := Subroutines_Holder.To_Holder (Indices_Array'(others => GL.Types.UInt'Last));
            end;
         end loop;
      end return;
   end Create_Program;

   function Create_Program (Module    : Programs.Modules.Module;
                            Separable : Boolean := False) return Program is
   begin
      return Create_Program (Modules.Module_Array'(1 => Module), Separable);
   end Create_Program;

   function GL_Program (Object : Program) return GL.Objects.Programs.Program
     is (Object.GL_Program);

   function Has_Subroutines (Object : Program) return Boolean
     is (Object.Has_Subroutines);

   procedure Use_Subroutines (Object : in out Program) is
   begin
      for Shader_Kind in Programs.Modules.Non_Compute_Shader_Type loop
         declare
            Indices : GL.Types.UInt_Array renames Object.Subroutines (Shader_Kind).Element;
         begin
            if Indices'Length > 0 then
               GL.Objects.Programs.Set_Uniform_Subroutines (Shader_Kind, Indices);
            end if;
         end;
      end loop;
      Object.Subroutines_Modified := False;
   end Use_Subroutines;

   procedure Use_Program (Object : in out Program) is
   begin
      if Current_Program.Is_Empty or else Object /= Current_Program.Element then
         Object.GL_Program.Use_Program;
         Current_Program.Replace_Element (Object);
         if Object.Has_Subroutines then
            Object.Use_Subroutines;
         end if;
      elsif Object.Subroutines_Modified then
         Object.Use_Subroutines;
      end if;
   end Use_Program;

   function Attribute_Location (Object : Program; Name : String)
      return GL.Attributes.Attribute is
   begin
      return Object.GL_Program.Attrib_Location (Name);
   end Attribute_Location;

   procedure Set_Subroutine_Function
     (Object   : in out Program;
      Shader   : GL.Objects.Shaders.Shader_Type;
      Location : Uniform_Location;
      Index    : Subroutine_Index)
   is
      procedure Set_Index (Indices : in out GL.Types.UInt_Array) is
      begin
         Indices (Location) := Index;
      end Set_Index;
   begin
      Object.Subroutines (Shader).Update_Element (Set_Index'Access);
      Object.Subroutines_Modified := True;
   end Set_Subroutine_Function;

   function Uniform_Sampler (Object : Program; Name : String)
     return Uniforms.Uniform_Sampler is
   begin
      return Uniforms.Create_Uniform_Sampler (Object, Name);
   end Uniform_Sampler;

   function Uniform_Image (Object : Program; Name : String)
     return Uniforms.Uniform_Image is
   begin
      return Uniforms.Create_Uniform_Image (Object, Name);
   end Uniform_Image;

   function Uniform_Subroutine
     (Object : in out Program;
      Shader : GL.Objects.Shaders.Shader_Type;
      Name   : String) return Uniforms.Uniform_Subroutine is
   begin
      return Uniforms.Create_Uniform_Subroutine (Object, Shader, Name);
   end Uniform_Subroutine;

   function Uniform_Block (Object : Program; Name : String)
     return Uniforms.Uniform_Block is
   begin
      return Uniforms.Create_Uniform_Block (Object, Name);
   end Uniform_Block;

   function Uniform (Object : Program; Name : String)
     return Uniforms.Uniform is
   begin
      return Uniforms.Create_Uniform_Variable (Object, Name);
   end Uniform;

end Orka.Programs;

orka: Make a program separable according to function parameter

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  awa-audits-services -- AWA Audit Manager
--  Copyright (C) 2018 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.Calendar;
with Util.Beans.Objects;
with ADO.Objects;
with ADO.Sessions.Entities;
with AWA.Audits.Models;
with AWA.Services.Contexts;
package body AWA.Audits.Services is

   package ASC renames AWA.Services.Contexts;
   package UBO renames Util.Beans.Objects;

   use type ASC.Service_Context_Access;

   --  ------------------------------
   --  Save the audit changes in the database.
   --  ------------------------------
   overriding
   procedure Save (Manager : in out Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in ADO.Audits.Auditable_Object_Record'Class;
                   Changes : in ADO.Audits.Audit_Array) is
      pragma Unreferenced (Manager);

      Context : constant ASC.Service_Context_Access := ASC.Current;
      Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind    : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : AWA.Audits.Models.Audit_Ref;
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            if UBO.Is_Null (C.Old_Value) then
               Audit.Set_Old_Value (ADO.Null_String);
            else
               Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            end if;
            if UBO.Is_Null (C.New_Value) then
               Audit.Set_New_Value (ADO.Null_String);
            else
               Audit.Set_New_Value (UBO.To_String (C.New_Value));
            end if;
            Audit.Set_Date (Now);
            if Context /= null then
               Audit.Set_Session (Context.Get_User_Session);
            end if;
            Audit.Save (Session);
         end;
      end loop;
   end Save;

end AWA.Audits.Services;

-----------------------------------------------------------------------
--  awa-audits-services -- AWA Audit Manager
--  Copyright (C) 2018 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.Calendar;
with Ada.Strings.Hash;

with Util.Strings;
with Util.Beans.Objects;
with Util.Log.Loggers;

with ADO.Objects;
with ADO.Schemas;
with ADO.Sessions.Entities;
with AWA.Audits.Models;
with AWA.Services.Contexts;
package body AWA.Audits.Services is

   package ASC renames AWA.Services.Contexts;
   package UBO renames Util.Beans.Objects;

   use type ASC.Service_Context_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Audits.Services");

   function Hash (Item : in Field_Key) return Ada.Containers.Hash_Type is
      use type Ada.Containers.Hash_Type;
   begin
      return Ada.Containers.Hash_Type (Item.Entity) + Ada.Strings.Hash (Item.Name);
   end Hash;

   --  ------------------------------
   --  Save the audit changes in the database.
   --  ------------------------------
   overriding
   procedure Save (Manager : in out Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in ADO.Audits.Auditable_Object_Record'Class;
                   Changes : in ADO.Audits.Audit_Array) is
      Context : constant ASC.Service_Context_Access := ASC.Current;
      Now     : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Class   : constant ADO.Schemas.Class_Mapping_Access
        := Object.Get_Key.Of_Class;
      Kind    : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : AWA.Audits.Models.Audit_Ref;
            Field : constant Util.Strings.Name_Access := Class.Members (C.Field);
         begin
            Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Field (Manager.Get_Audit_Field (Field.all, Kind));
            if UBO.Is_Null (C.Old_Value) then
               Audit.Set_Old_Value (ADO.Null_String);
            else
               Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            end if;
            if UBO.Is_Null (C.New_Value) then
               Audit.Set_New_Value (ADO.Null_String);
            else
               Audit.Set_New_Value (UBO.To_String (C.New_Value));
            end if;
            Audit.Set_Date (Now);
            if Context /= null then
               Audit.Set_Session (Context.Get_User_Session);
            end if;
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   --  ------------------------------
   --  Find the audit field identification number from the entity type and field name.
   --  ------------------------------
   function Get_Audit_Field (Manager : in Audit_Manager;
                             Name    : in String;
                             Entity  : in ADO.Entity_Type) return ADO.Identifier is
      Key : constant Field_Key := Field_Key '(Len    => Name'Length,
                                              Name   => Name,
                                              Entity => Entity);
      Pos : constant Audit_Field_Maps.Cursor := Manager.Fields.Find (Key);
   begin
      if Audit_Field_Maps.Has_Element (Pos) then
         return Audit_Field_Maps.Element (Pos);
      else
         Log.Warn ("Audit field {0} for {1} not found", Name, ADO.Entity_Type'Image (Entity));
         return ADO.NO_IDENTIFIER;
      end if;
   end Get_Audit_Field;

end AWA.Audits.Services;

Implement Get_Audit_Field and Hash

Implement Get_Audit_Field and Hash


-----------------------------------------------------------------------
--  awa-blogs-services -- Blogs and post management
--  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 ADO;

with AWA.Modules;
with AWA.Blogs.Models;

with Security.Permissions;

--  The Blogs.Services package defines the service and operations to
--  create, update and delete a post.
package AWA.Blogs.Services is

   NAME : constant String := "Blog_Service";

   --  Define the permissions.
   package ACL_Create_Blog is new Security.Permissions.Permission_ACL ("blog-create");
   package ACL_Delete_Blog is new Security.Permissions.Permission_ACL ("blog-delete");
   package ACL_Create_Post is new Security.Permissions.Permission_ACL ("blog-create-post");
   package ACL_Delete_Post is new Security.Permissions.Permission_ACL ("blog-delete-post");
   package ACL_Update_Post is new Security.Permissions.Permission_ACL ("blog-update-post");

   --  Exception raised when a post cannot be found.
   Not_Found : exception;

   type Blog_Service is new AWA.Modules.Module_Manager with private;
   type Blog_Service_Access is access all Blog_Service'Class;

   --  Create a new blog for the user workspace.
   procedure Create_Blog (Model        : in Blog_Service;
                          Workspace_Id : in ADO.Identifier;
                          Title        : in String;
                          Result       : out ADO.Identifier);

   --  Create a new post associated with the given blog identifier.
   procedure Create_Post (Model   : in Blog_Service;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Status  : in AWA.Blogs.Models.Post_Status_Type;
                          Result  : out ADO.Identifier);

   --  Update the post title and text associated with the blog post identified by Post.
   procedure Update_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          Text    : in String;
                          Status  : in AWA.Blogs.Models.Post_Status_Type);

   --  Delete the post identified by the given identifier.
   procedure Delete_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier);

private

   type Blog_Service is new AWA.Modules.Module_Manager with null record;

end AWA.Blogs.Services;

-----------------------------------------------------------------------
--  awa-blogs-services -- Blogs and post management
--  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 ADO;

with AWA.Modules;
with AWA.Blogs.Models;

with Security.Permissions;

--  The Blogs.Services package defines the service and operations to
--  create, update and delete a post.
package AWA.Blogs.Services is

   NAME : constant String := "Blog_Service";

   --  Define the permissions.
   package ACL_Create_Blog is new Security.Permissions.Definition ("blog-create");
   package ACL_Delete_Blog is new Security.Permissions.Definition ("blog-delete");
   package ACL_Create_Post is new Security.Permissions.Definition ("blog-create-post");
   package ACL_Delete_Post is new Security.Permissions.Definition ("blog-delete-post");
   package ACL_Update_Post is new Security.Permissions.Definition ("blog-update-post");

   --  Exception raised when a post cannot be found.
   Not_Found : exception;

   type Blog_Service is new AWA.Modules.Module_Manager with private;
   type Blog_Service_Access is access all Blog_Service'Class;

   --  Create a new blog for the user workspace.
   procedure Create_Blog (Model        : in Blog_Service;
                          Workspace_Id : in ADO.Identifier;
                          Title        : in String;
                          Result       : out ADO.Identifier);

   --  Create a new post associated with the given blog identifier.
   procedure Create_Post (Model   : in Blog_Service;
                          Blog_Id : in ADO.Identifier;
                          Title   : in String;
                          URI     : in String;
                          Text    : in String;
                          Status  : in AWA.Blogs.Models.Post_Status_Type;
                          Result  : out ADO.Identifier);

   --  Update the post title and text associated with the blog post identified by Post.
   procedure Update_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier;
                          Title   : in String;
                          Text    : in String;
                          Status  : in AWA.Blogs.Models.Post_Status_Type);

   --  Delete the post identified by the given identifier.
   procedure Delete_Post (Model   : in Blog_Service;
                          Post_Id : in ADO.Identifier);

private

   type Blog_Service is new AWA.Modules.Module_Manager with null record;

end AWA.Blogs.Services;

Use the Permissions.Definition generic package


-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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.Containers.Vectors;

with MAT.Events.Targets;
package MAT.Events.Timelines is

   --  Describe a section of the timeline.  The section has a starting and ending
   --  event that marks the boundary of the section within the collected events.
   --  The timeline section gives the duration and some statistics about memory
   --  allocation made in the section.
   type Timeline_Info is record
      Start_Id       : MAT.Events.Targets.Event_Id_Type := 0;
      Start_Time     : MAT.Types.Target_Tick_Ref := 0;
      End_Id         : MAT.Events.Targets.Event_Id_Type := 0;
      End_Time       : MAT.Types.Target_Tick_Ref := 0;
      Duration       : MAT.Types.Target_Time := 0;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
   end record;

   package Timeline_Info_Vectors is
     new Ada.Containers.Vectors (Positive, Timeline_Info);

   subtype Timeline_Info_Vector is Timeline_Info_Vectors.Vector;
   subtype Timeline_Info_Cursor is Timeline_Info_Vectors.Cursor;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector);

end MAT.Events.Timelines;

-----------------------------------------------------------------------
--  mat-events-timelines - Timelines
--  Copyright (C) 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.Containers.Vectors;

with MAT.Events.Targets;
package MAT.Events.Timelines is

   --  Describe a section of the timeline.  The section has a starting and ending
   --  event that marks the boundary of the section within the collected events.
   --  The timeline section gives the duration and some statistics about memory
   --  allocation made in the section.
   type Timeline_Info is record
      Start_Id       : MAT.Events.Targets.Event_Id_Type := 0;
      Start_Time     : MAT.Types.Target_Tick_Ref := 0;
      End_Id         : MAT.Events.Targets.Event_Id_Type := 0;
      End_Time       : MAT.Types.Target_Tick_Ref := 0;
      Duration       : MAT.Types.Target_Time := 0;
      Malloc_Count   : Natural := 0;
      Realloc_Count  : Natural := 0;
      Free_Count     : Natural := 0;
   end record;

   package Timeline_Info_Vectors is
     new Ada.Containers.Vectors (Positive, Timeline_Info);

   subtype Timeline_Info_Vector is Timeline_Info_Vectors.Vector;
   subtype Timeline_Info_Cursor is Timeline_Info_Vectors.Cursor;

   procedure Extract (Target : in out MAT.Events.Targets.Target_Events;
                      Into   : in out Timeline_Info_Vector);

   --  Find in the events stream the events which are associated with a given event.
   --  When the <tt>Event</tt> is a memory allocation, find the associated reallocation
   --  and free events.  When the event is a free, find the associated allocations.
   --  Collect at most <tt>Max</tt> events.
   procedure Find_Related (Target : in out MAT.Events.Targets.Target_Events'Class;
                           Event  : in MAT.Events.Targets.Probe_Event_Type;
                           Max    : in Positive;
                           List   : in out MAT.Events.Targets.Target_Event_Vector);

end MAT.Events.Timelines;

Declare the Find_Related procedure to find the related event from an known event


-----------------------------------------------------------------------
--  asf.requests -- ASF Requests
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 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 EL.Objects;
with EL.Contexts;

with Util.Locales;
with Util.Beans.Objects.Maps;
with Util.Streams.Buffered;

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

with ASF.Cookies;
with ASF.Sessions;
with ASF.Responses;
with ASF.Principals;
with ASF.Parts;
with ASF.Routes;
with ASF.Streams;

--  The ASF.Requests package is an Ada implementation of
--  the Java servlet request (JSR 315 3. The Request).
package ASF.Requests is

   use Ada.Strings.Unbounded;

   type Quality_Type is digits 4 range 0.0 .. 1.0;

   --  Split an accept like header into multiple tokens and a quality value.
   --  Invoke the Process procedure for each token.  Example:
   --   Accept-Language: de, en;q=0.7, jp, fr;q=0.8, ru
   --  The Process will be called for "de", "en" with quality 0.7,
   --  and "jp", "fr" with quality 0.8 and then "ru" with quality 1.0.
   procedure Split_Header (Header  : in String;
                           Process : access procedure (Item : in String;
                                                       Quality : in Quality_Type));

   --  ------------------------------
   --  Request
   --  ------------------------------
   --  The Request type describes a web request that a servlet can process.
   type Request is abstract new Ada.Finalization.Limited_Controlled with private;
   type Request_Access is access all Request'Class;

   --  Returns the value of the named attribute as an Object, or null if no attribute
   --  of the given name exists.
   --
   --  Attributes can be set two ways. The servlet container may set attributes to make
   --  available custom information about a request. For example, for requests made
   --  using HTTPS, the attribute javax.servlet.request.X509Certificate can be used
   --  to retrieve information on the certificate of the client. Attributes can also
   --  be set programatically using setAttribute(String, Object).
   --  This allows information to be embedded into a request before
   --  a RequestDispatcher call.
   function Get_Attribute (Req  : in Request;
                           Name : in String) return EL.Objects.Object;

   --  Stores an attribute in this request. Attributes are reset between requests.
   --  This method is most often used in conjunction with RequestDispatcher.
   --
   --  If the object passed in is null, the effect is the same as calling
   --  removeAttribute(java.lang.String).  It is warned that when the request is
   --  dispatched from the servlet resides in a different web application by
   --  RequestDispatcher, the object set by this method may not be correctly
   --  retrieved in the caller servlet.
   procedure Set_Attribute (Req   : in out Request;
                            Name  : in String;
                            Value : in EL.Objects.Object);

   --  Stores a list of attributes in this request.
   procedure Set_Attributes (Req        : in out Request;
                             Attributes : in Util.Beans.Objects.Maps.Map);

   --  Removes an attribute from this request. This method is not generally needed
   --  as attributes only persist as long as the request is being handled.
   procedure Remove_Attribute (Req  : in out Request;
                               Name : in String);

   --  Iterate over the request attributes and executes the Process procedure.
   procedure Iterate_Attributes (Req     : in Request;
                                 Process : not null access
                                   procedure (Name : in String;
                                              Value : in EL.Objects.Object));

   --  Returns the name of the character encoding used in the body of this request.
   --  This method returns null if the request does not specify a character encoding
   function Get_Character_Encoding (Req : in Request) return String;

   --  Overrides the name of the character encoding used in the body of this request.
   --  This method must be called prior to reading request parameters or reading input
   --  using getReader(). Otherwise, it has no effect.
   procedure Set_Character_Encoding (Req : in out Request;
                                     Encoding : in String);

   --  Returns the length, in bytes, of the request body and made available by the
   --  input stream, or -1 if the length is not known. For HTTP servlets,
   --  same as the value of the CGI variable CONTENT_LENGTH.
   function Get_Content_Length (Req : in Request) return Integer;

   --  Returns the MIME type of the body of the request, or null if the type is
   --  not known. For HTTP servlets, same as the value of the CGI variable CONTENT_TYPE.
   function Get_Content_Type (Req : in Request) return String;

   --  Returns the value of a request parameter as a String, or null if the
   --  parameter does not exist. Request parameters are extra information sent with
   --  the request. For HTTP servlets, parameters are contained in the query string
   --  or posted form data.
   --
   --  You should only use this method when you are sure the parameter has only one
   --  value. If the parameter might have more than one value, use
   --  Get_Parameter_Values(String).
   --
   --  If you use this method with a multivalued parameter, the value returned is
   --  equal to the first value in the array returned by Get_Parameter_Values.
   --
   --  If the parameter data was sent in the request body, such as occurs with
   --  an HTTP POST request, then reading the body directly via getInputStream()
   --  or getReader() can interfere with the execution of this method.
   --
   function Get_Parameter (Req  : in Request;
                           Name : in String)
                           return String is abstract;

   --  Returns an array of String objects containing all of the values the given
   --  request parameter has, or null if the parameter does not exist.
   --
   --  If the parameter has a single value, the array has a length of 1.
   function Get_Parameter_Values (Req  : in Request;
                                  Name : in String) return String;

   --  Iterate over the request parameters and executes the Process procedure.
   procedure Iterate_Parameters (Req     : in Request;
                                 Process : not null access
                                   procedure (Name  : in String;
                                              Value : in String)) is abstract;

   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   function Get_Protocol (Req : in Request) return String;

   --  Returns the name of the scheme used to make this request, for example, http,
   --  https, or ftp. Different schemes have different rules for constructing URLs,
   --  as noted in RFC 1738.
   function Get_Scheme (Req : in Request) return String;

   --  Returns the host name of the server to which the request was sent.
   --  It is the value of the part before ":" in the Host  header value, if any,
   --  or the resolved server name, or the server IP address.
   function Get_Server_Name (Req : in Request) return String;

   --  Returns the port number to which the request was sent. It is the value of the
   --  part after ":" in the Host  header value, if any, or the server port where the
   --  client connection was accepted on.
   function Get_Server_Port (Req : in Request) return Natural;

   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   function Get_Remote_Addr (Req : in Request) return String;

   --  Returns the fully qualified name of the client or the last proxy that sent
   --  the request. If the engine cannot or chooses not to resolve the hostname
   --  (to improve performance), this method returns the dotted-string form of the
   --  IP address. For HTTP servlets, same as the value of the CGI variable REMOTE_HOST.
   function Get_Remote_Host (Req : in Request) return String;

   --  Returns the preferred Locale that the client will accept content in, based
   --  on the Accept-Language header. If the client request doesn't provide an
   --  Accept-Language header, this method returns the default locale for the server.
   function Get_Locale (Req : in Request) return Util.Locales.Locale;

   --  Returns an Enumeration of Locale objects indicating, in decreasing order
   --  starting with the preferred locale, the locales that are acceptable to the
   --  client based on the Accept-Language header. If the client request doesn't
   --  provide an Accept-Language header, this method returns an Enumeration containing
   --  one Locale, the default locale for the server.
   function Get_Locales (Req : in Request) return Util.Locales.Locale;

   --  From the Accept-Language request header, find the locales that are recognized
   --  by the client and execute the Process procedure with each locale and the
   --  associated quality value (ranging from 0.0 to 1.0).
   procedure Accept_Locales (Req     : in Request;
                             Process : access procedure (Item    : in Util.Locales.Locale;
                                                         Quality : in Quality_Type));

   --  Returns a boolean indicating whether this request was made using a secure
   --  channel, such as HTTPS.
   function Is_Secure (Req : in Request) return Boolean;

   --  Returns the Internet Protocol (IP) source port of the client or last proxy
   --  that sent the request.
   function Get_Remote_Port (Req : in Request) return Natural;

   --  Returns the host name of the Internet Protocol (IP) interface on which
   --  the request was received.
   function Get_Local_Name (Req : in Request) return String;

   --  Returns the Internet Protocol (IP) address of the interface on which the
   --  request was received.
   function Get_Local_Addr (Req : in Request) return String;

   --  Returns the Internet Protocol (IP) port number of the interface on which
   --  the request was received.
   function Get_Local_Port (Req : in Request) return Natural;

   --  Returns the name of the authentication scheme used to protect the servlet.
   --  All servlet containers support basic, form and client certificate authentication,
   --  and may additionally support digest authentication. If the servlet is not
   --  authenticated null is returned.
   function Get_Auth_Type (Req : in Request) return String;

   --  Returns an array containing all of the Cookie  objects the client sent with
   --  this request. This method returns null if no cookies were sent.
   function Get_Cookies (Req : in Request) return ASF.Cookies.Cookie_Array;

   --  Iterate over the request cookies and executes the Process procedure.
   procedure Iterate_Cookies (Req     : in Request;
                              Process : not null access
                                procedure (Cookie : in ASF.Cookies.Cookie));

   --  Returns the value of the specified request header as a long value that
   --  represents a Date object. Use this method with headers that contain dates,
   --  such as If-Modified-Since.
   --
   --  The date is returned as the number of milliseconds since January 1, 1970 GMT.
   --  The header name is case insensitive.
   --
   --  If the request did not have a header of the specified name, this method
   --  returns -1. If the header can't be converted to a date, the method throws
   --  an IllegalArgumentException.
   function Get_Date_Header (Req  : in Request;
                             Name : in String) return Ada.Calendar.Time;

   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any request header.
   function Get_Header (Req  : in Request;
                        Name : in String) return String;

   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   function Get_Headers (Req  : in Request;
                         Name : in String) return String;

   --  Returns the value of the specified request header as an int. If the request
   --  does not have a header of the specified name, this method returns -1.
   --  If the header cannot be converted to an integer, this method throws
   --  a NumberFormatException.
   --
   --  The header name is case insensitive.
   function Get_Int_Header (Req  : in Request;
                            Name : in String) return Integer;

   --  Iterate over the request headers and executes the Process procedure.
   procedure Iterate_Headers (Req     : in Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is abstract;

   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   function Get_Method (Req : in Request) return String;

   --  Returns any extra path information associated with the URL the client sent when
   --  it made this request. The extra path information follows the servlet path but
   --  precedes the query string and will start with a "/" character.
   function Get_Path_Info (Req : in Request) return String;

   --  Get the request path that correspond to the servlet path and the path info.
   function Get_Path (Req : in Request) return String;

   --  Returns the portion of the request URI that indicates the context of the
   --  request. The context path always comes first in a request URI. The path
   --  starts with a "/" character but does not end with a "/" character.
   --  For servlets in the default (root) context, this method returns "".
   --  The container does not decode this string.
   function Get_Context_Path (Req : in Request) return String;

   --  Returns the query string that is contained in the request URL after the path.
   --  This method returns null  if the URL does not have a query string. Same as the
   --  value of the CGI variable QUERY_STRING.
   function Get_Query_String (Req : in Request) return String;

   --  Returns the login of the user making this request, if the user has been
   --  authenticated, or null if the user has not been authenticated. Whether
   --  the user name is sent with each subsequent request depends on the browser
   --  and type of authentication. Same as the value of the CGI variable REMOTE_USER.
   function Get_Remote_User (Req : in Request) return String;

   --  Returns a Principal object containing the name of the current
   --  authenticated user. If the user has not been authenticated, the method returns null.
   function Get_User_Principal (Req : in Request) return ASF.Principals.Principal_Access;

   --  Returns the session ID specified by the client. This may not be the same as
   --  the ID of the current valid session for this request. If the client did not
   --  specify a session ID, this method returns null.
   function Get_Request_Session_Id (Req : in Request) return String;

   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   function Get_Request_URI (Req : in Request) return String;

   --  Reconstructs the URL the client used to make the request. The returned URL
   --  contains a protocol, server name, port number, and server path, but it does
   --  not include query string parameters.
   --
   --  If this request has been forwarded using RequestDispatcher.forward(Request, Response),
   --  the server path in the reconstructed URL must reflect the path used to
   --  obtain the RequestDispatcher, and not the server path specified by the client.
   --
   --  Because this method returns a StringBuffer, not a string, you can modify the
   --  URL easily, for example, to append query parameters.
   --
   --  This method is useful for creating redirect messages and for reporting errors.
   function Get_Request_URL (Req : in Request) return Ada.Strings.Unbounded.Unbounded_String;

   --  Returns the part of this request's URL that calls the servlet. This path starts
   --  with a "/" character and includes either the servlet name or a path to the
   --  servlet, but does not include any extra path information or a query string.
   --  Same as the value of the CGI variable SCRIPT_NAME.
   --
   --  This method will return an empty string ("") if the servlet used to process
   --  this request was matched using the "/*" pattern.
   function Get_Servlet_Path (Req : in Request) return String;

   --  Returns the current HttpSession  associated with this request or, if there
   --  is no current session and create is true, returns a new session.
   --
   --  If create is false  and the request has no valid HttpSession, this method
   --  returns null.
   --
   --  To make sure the session is properly maintained, you must call this method
   --  before the response is committed. If the container is using cookies to maintain
   --  session integrity and is asked to create a new session when the response is
   --  committed, an IllegalStateException is thrown.
   function Get_Session (Req    : in Request;
                         Create : in Boolean := False) return ASF.Sessions.Session;

   --  Set the path info.  The <tt>Path_Pos</tt> parameter indicates the optional starting
   --  position for the path info.  When specified, the servlet path is built from the
   --  beginning of the path up to that path position.
   procedure Set_Path_Info (Req      : in out Request;
                            Path     : in String;
                            Path_Pos : in Natural := 0);

   --  Get the number of parts included in the request.
   function Get_Part_Count (Req : in Request) return Natural is abstract;

   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is abstract;

   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is abstract;

   --  Returns True if the request is an AJAX request.
   function Is_Ajax_Request (Req : in Request) return Boolean;

   --  Returns the absolute path of the resource identified by the given relative path.
   --  The resource is searched in a list of directories configured by the application.
   --  The path must begin with a "/" and is interpreted as relative to the current
   --  context root.
   --
   --  This method allows the servlet container to make a resource available to
   --  servlets from any source.
   --
   --  This method returns an empty string if the resource could not be localized.
   function Get_Resource (Req  : in Request;
                          Path : in String) return String;

   --  Returns the route object that is associated with the request.
   function Get_Route (Req : in Request) return ASF.Routes.Route_Type_Access;

   --  Inject the parameters that have been extracted from the path according
   --  to the selected route.  The parameters are injected in the request attributes map.
   procedure Inject_Parameters (Req       : in out Request;
                                ELContext : in EL.Contexts.ELContext'Class);

   --  Get the path parameter value for the given parameter index.
   --  The <tt>No_Parameter</tt> exception is raised if the parameter does not exist.
   function Get_Path_Parameter (Req     : in Request;
                                Index   : in Positive) return String;

   --  Get the number of path parameters that were extracted for the route.
   function Get_Path_Parameter_Count (Req     : in Request) return Natural;

   --  Get a buffer stream to read the request body.
   function Get_Input_Stream (Req : in Request)
                              return ASF.Streams.Input_Stream_Access;

   --  Create the buffer stream instance to read the request body.
   function Create_Input_Stream (Req : in Request)
                                 return ASF.Streams.Input_Stream_Access is (null);

   --  Initialize the request object.
   overriding
   procedure Initialize (Req : in out Request);

   --  Finalize the request object.
   overriding
   procedure Finalize (Req : in out Request);

private

   --  Make sure the cookies are loaded in the request object.
   procedure Load_Cookies (Req : in Request'Class);

   --  Get and check the request session
   function Has_Session (Req : in Request'Class) return Boolean;

   type Request_Data is record
      --  The session
      Session             : ASF.Sessions.Session;

      --  Indicates whether the session object is known.
      Session_Initialized : Boolean := False;

      --  The response object associated with the request.
      Response            : ASF.Responses.Response_Access;

      --  The request cookies.
      Cookies             : ASF.Cookies.Cookie_Array_Access := null;

      --  The input stream.
      Stream              : ASF.Streams.Input_Stream_Access;
   end record;
   type Request_Data_Access is access Request_Data;

   type Request is abstract new Ada.Finalization.Limited_Controlled with record
      Attributes  : Util.Beans.Objects.Maps.Map_Bean;
      Info        : Request_Data_Access := null;
      Context     : access ASF.Routes.Route_Context_Type;
   end record;

end ASF.Requests;

-----------------------------------------------------------------------
--  asf-requests -- ASF Requests
--  Copyright (C) 2010, 2011, 2012, 2013, 2015, 2016, 2017, 2018 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 Servlet.Requests;
package ASF.Requests renames Servlet.Requests;

Package ASF.Requests moved to Servlet.Requests