-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 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 Ada.Strings.Unbounded;
with Ada.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Dates.ISO8601;

package body Util.Serialize.IO.CSV is

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

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

   --  ------------------------------
   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   --  ------------------------------
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
      for I in Value'Range loop
         if Value (I) = '"' then
            Stream.Write ("""""");
         else
            Stream.Write (Value (I));
         end if;
      end loop;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      Stream.Write (Util.Strings.Image (Value));
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Value then
         Stream.Write ("true");
      else
         Stream.Write ("false");
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Stream.Quote then
               Stream.Write ("""null""");
            else
               Stream.Write ("null");
            end if;

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

         when TYPE_INTEGER =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            --  Stream.Write ('"');
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));
            --  Stream.Write ('"');

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

      end case;
   end Write_Cell;

   --  ------------------------------
   --  Start a new row.
   --  ------------------------------
   procedure New_Row (Stream : in out Output_Stream) is
   begin
      while Stream.Column < Stream.Max_Columns loop
         Stream.Write (Stream.Separator);
         Stream.Column := Stream.Column + 1;
      end loop;
      Stream.Write (ASCII.CR);
      Stream.Write (ASCII.LF);
      Stream.Column := 1;
      Stream.Row := Stream.Row + 1;
   end New_Row;

   --  -----------------------
   --  Write the attribute name/value pair.
   --  -----------------------
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   --  -----------------------
   --  Write the entity value.
   --  -----------------------
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is
   begin
      Stream.Write_Entity (Name, Util.Dates.ISO8601.Image (Value, Util.Dates.ISO8601.SUBSECOND));
   end Write_Entity;

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is
   begin
      null;
   end Write_Long_Entity;

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is
   begin
      Stream.Write_Entity (Name, Value);
   end Write_Enum_Entity;

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

      Default_Header : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
      Result : String (1 .. 10);
      N, R   : Natural;
      Pos    : Positive := Result'Last;
   begin
      if Handler.Headers.Length >= Ada.Containers.Count_Type (Column) then
         return Handler.Headers.Element (Positive (Column));
      end if;
      N := Natural (Column - 1);
      loop
         R := N mod 26;
         N := N / 26;
         Result (Pos) := Default_Header (R + 1);
         exit when N = 0;
         Pos := Pos - 1;
      end loop;
      return Result (Pos .. Result'Last);
   end Get_Header_Name;

   --  ------------------------------
   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   --  ------------------------------
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type) is
      use Ada.Containers;
   begin
      if Row = 0 then
         --  Build the headers table.
         declare
            Missing : constant Integer := Integer (Column) - Integer (Handler.Headers.Length);
         begin
            if Missing > 0 then
               Handler.Headers.Set_Length (Handler.Headers.Length + Count_Type (Missing));
            end if;
            Handler.Headers.Replace_Element (Positive (Column), Value);
         end;
      else
         declare
            Name : constant String := Handler.Get_Header_Name (Column);
         begin
            --  Detect a new row.  Close the current object and start a new one.
            if Handler.Row /= Row then
               if Row > 1 then
                  Handler.Sink.Finish_Object ("");
               end if;
               Handler.Sink.Start_Object ("");
            end if;
            Handler.Row := Row;
            Handler.Sink.Set_Member (Name, Util.Beans.Objects.To_Object (Value));
         end;
      end if;
   end Set_Cell;

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

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

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

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

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

   --  ------------------------------
   --  Parse the stream using the CSV parser.
   --  Call Set_Cell for each cell that has been parsed indicating the row and
   --  column numbers as well as the cell value.
   --  ------------------------------
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class) is
      use Ada.Strings.Unbounded;

      C              : Character;
      Token          : Unbounded_String;
      Column         : Column_Type := 1;
      Row            : Row_Type  := 0;
      In_Quote_Token : Boolean := False;
      In_Escape      : Boolean := False;
      Ignore_Row     : Boolean := False;
      --  Context        : Element_Context_Access;
   begin
      --  Context_Stack.Push (Handler.Stack);
      --  Context := Context_Stack.Current (Handler.Stack);
      --  Context.Active_Nodes (1) := Handler.Mapping_Tree'Unchecked_Access;
      if Handler.Use_Default_Headers then
         Row := 1;
      end if;
      Handler.Headers.Clear;
      Handler.Sink := Sink'Unchecked_Access;
      loop
         Stream.Read (Char => C);

         if C = Ada.Characters.Latin_1.CR  or C = Ada.Characters.Latin_1.LF then
            if C = Ada.Characters.Latin_1.LF then
               Handler.Line_Number := Handler.Line_Number + 1;
            end if;
            if not Ignore_Row then
               if In_Quote_Token and not In_Escape then
                  Append (Token, C);

               elsif Column > 1 or else Length (Token) > 0 then
                  Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
                  Set_Unbounded_String (Token, "");
                  Row            := Row + 1;
                  Column         := 1;
                  In_Quote_Token := False;
                  In_Escape      := False;
               end if;
            else
               Ignore_Row := False;
            end if;

         elsif C = Handler.Separator and not Ignore_Row then
            if In_Quote_Token and not In_Escape then
               Append (Token, C);

            else
               Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
               Set_Unbounded_String (Token, "");
               Column         := Column + 1;
               In_Quote_Token := False;
               In_Escape      := False;
            end if;

         elsif C = '"' and not Ignore_Row then
            if In_Quote_Token then
               In_Escape := True;

            elsif In_Escape then
               Append (Token, C);
               In_Escape := False;

            elsif Ada.Strings.Unbounded.Length (Token) = 0 then
               In_Quote_Token := True;

            else
               Append (Token, C);
            end if;

         elsif C = Handler.Comment and Handler.Comment /= ASCII.NUL
           and Column = 1 and Length (Token) = 0
         then
            Ignore_Row := True;

         elsif not Ignore_Row then
            Append (Token, C);
            In_Escape := False;

         end if;

      end loop;
      Handler.Sink := null;

   exception
      when Ada.IO_Exceptions.Data_Error =>
         Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
         --  Context_Stack.Pop (Handler.Stack);
         Handler.Sink := null;
         return;
   end Parse;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   overriding
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

end Util.Serialize.IO.CSV;

-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 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 Ada.Strings.Unbounded;
with Ada.Characters.Latin_1;
with Ada.IO_Exceptions;

with Util.Strings;
with Util.Dates.ISO8601;

package body Util.Serialize.IO.CSV is

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

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

   --  ------------------------------
   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   --  ------------------------------
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
      for I in Value'Range loop
         if Value (I) = '"' then
            Stream.Write ("""""");
         else
            Stream.Write (Value (I));
         end if;
      end loop;
      if Stream.Quote then
         Stream.Write ('"');
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      Stream.Write (Util.Strings.Image (Value));
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean) is
   begin
      if Stream.Column > 1 then
         Stream.Write (Stream.Separator);
      end if;
      Stream.Column := Stream.Column + 1;
      if Value then
         Stream.Write ("true");
      else
         Stream.Write ("false");
      end if;
   end Write_Cell;

   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            if Stream.Quote then
               Stream.Write ("""null""");
            else
               Stream.Write ("null");
            end if;

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

         when TYPE_INTEGER =>
            if Stream.Column > 1 then
               Stream.Write (Stream.Separator);
            end if;
            Stream.Column := Stream.Column + 1;
            --  Stream.Write ('"');
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));
            --  Stream.Write ('"');

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

      end case;
   end Write_Cell;

   --  ------------------------------
   --  Start a new row.
   --  ------------------------------
   procedure New_Row (Stream : in out Output_Stream) is
   begin
      while Stream.Column < Stream.Max_Columns loop
         Stream.Write (Stream.Separator);
         Stream.Column := Stream.Column + 1;
      end loop;
      Stream.Write (ASCII.CR);
      Stream.Write (ASCII.LF);
      Stream.Column := 1;
      Stream.Row := Stream.Row + 1;
   end New_Row;

   --  -----------------------
   --  Write the attribute name/value pair.
   --  -----------------------
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   --  -----------------------
   --  Write the entity value.
   --  -----------------------
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is
   begin
      null;
   end Write_Wide_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is
      pragma Unreferenced (Name);
   begin
      Stream.Write_Cell (Value);
   end Write_Entity;

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is
   begin
      Stream.Write_Entity (Name, Util.Dates.ISO8601.Image (Value, Util.Dates.ISO8601.SUBSECOND));
   end Write_Entity;

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is
   begin
      null;
   end Write_Long_Entity;

   overriding
   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is
   begin
      Stream.Write_Entity (Name, Value);
   end Write_Enum_Entity;

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

      Default_Header : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
      Result : String (1 .. 10);
      N, R   : Natural;
      Pos    : Positive := Result'Last;
   begin
      if Handler.Headers.Length >= Ada.Containers.Count_Type (Column) then
         return Handler.Headers.Element (Positive (Column));
      end if;
      N := Natural (Column - 1);
      loop
         R := N mod 26;
         N := N / 26;
         Result (Pos) := Default_Header (R + 1);
         exit when N = 0;
         Pos := Pos - 1;
      end loop;
      return Result (Pos .. Result'Last);
   end Get_Header_Name;

   --  ------------------------------
   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   --  ------------------------------
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type) is
      use Ada.Containers;
   begin
      if Row = 0 then
         --  Build the headers table.
         declare
            Missing : constant Integer := Integer (Column) - Integer (Handler.Headers.Length);
         begin
            if Missing > 0 then
               Handler.Headers.Set_Length (Handler.Headers.Length + Count_Type (Missing));
            end if;
            Handler.Headers.Replace_Element (Positive (Column), Value);
         end;
      else
         declare
            Name : constant String := Handler.Get_Header_Name (Column);
         begin
            --  Detect a new row.  Close the current object and start a new one.
            if Handler.Row /= Row then
               if Row > 1 then
                  Handler.Sink.Finish_Object ("");
               else
                  Handler.Sink.Start_Array ("");
               end if;
               Handler.Sink.Start_Object ("");
            end if;
            Handler.Row := Row;
            Handler.Sink.Set_Member (Name, Util.Beans.Objects.To_Object (Value));
         end;
      end if;
   end Set_Cell;

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

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

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

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

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

   --  ------------------------------
   --  Parse the stream using the CSV parser.
   --  Call Set_Cell for each cell that has been parsed indicating the row and
   --  column numbers as well as the cell value.
   --  ------------------------------
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class) is
      use Ada.Strings.Unbounded;

      C              : Character;
      Token          : Unbounded_String;
      Column         : Column_Type := 1;
      Row            : Row_Type  := 0;
      In_Quote_Token : Boolean := False;
      In_Escape      : Boolean := False;
      Ignore_Row     : Boolean := False;
      --  Context        : Element_Context_Access;
   begin
      --  Context_Stack.Push (Handler.Stack);
      --  Context := Context_Stack.Current (Handler.Stack);
      --  Context.Active_Nodes (1) := Handler.Mapping_Tree'Unchecked_Access;
      if Handler.Use_Default_Headers then
         Row := 1;
      end if;
      Handler.Headers.Clear;
      Handler.Sink := Sink'Unchecked_Access;
      loop
         Stream.Read (Char => C);

         if C = Ada.Characters.Latin_1.CR  or C = Ada.Characters.Latin_1.LF then
            if C = Ada.Characters.Latin_1.LF then
               Handler.Line_Number := Handler.Line_Number + 1;
            end if;
            if not Ignore_Row then
               if In_Quote_Token and not In_Escape then
                  Append (Token, C);

               elsif Column > 1 or else Length (Token) > 0 then
                  Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
                  Set_Unbounded_String (Token, "");
                  Row            := Row + 1;
                  Column         := 1;
                  In_Quote_Token := False;
                  In_Escape      := False;
               end if;
            else
               Ignore_Row := False;
            end if;

         elsif C = Handler.Separator and not Ignore_Row then
            if In_Quote_Token and not In_Escape then
               Append (Token, C);

            else
               Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
               Set_Unbounded_String (Token, "");
               Column         := Column + 1;
               In_Quote_Token := False;
               In_Escape      := False;
            end if;

         elsif C = '"' and not Ignore_Row then
            if In_Quote_Token then
               In_Escape := True;

            elsif In_Escape then
               Append (Token, C);
               In_Escape := False;

            elsif Ada.Strings.Unbounded.Length (Token) = 0 then
               In_Quote_Token := True;

            else
               Append (Token, C);
            end if;

         elsif C = Handler.Comment and Handler.Comment /= ASCII.NUL
           and Column = 1 and Length (Token) = 0
         then
            Ignore_Row := True;

         elsif not Ignore_Row then
            Append (Token, C);
            In_Escape := False;

         end if;

      end loop;
      Handler.Sink := null;

   exception
      when Ada.IO_Exceptions.Data_Error =>
         Parser'Class (Handler).Set_Cell (To_String (Token), Row, Column);
         --  Context_Stack.Pop (Handler.Stack);
         Handler.Sink := null;
         return;
   end Parse;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   overriding
   function Get_Location (Handler : in Parser) return String is
   begin
      return Util.Strings.Image (Handler.Line_Number);
   end Get_Location;

end Util.Serialize.IO.CSV;

Call the Start_Array for the first row of the CSV file (excluding the header)


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

with Util.Tests;

with EL.Contexts.Default;
with EL.Variables;

with ASF.Tests;
with ASF.Applications.Tests;
with ASF.Helpers.Beans;

package ASF.Contexts.Faces.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   function Get_Form_Bean is
     new ASF.Helpers.Beans.Get_Bean (ASF.Applications.Tests.Form_Bean,
                                     ASF.Applications.Tests.Form_Bean_Access);

   type Test is new ASF.Tests.EL_Test with record
      --  The ELContext, Variables, Resolver, Form area controlled object.
      --  Due to AUnit implementation, we cannot store a controlled object in the Test object.
      --  This is due to the 'for Obj'Address use Ret;' clause used by AUnit to allocate
      --  a test object.
      --  The application object is allocated dyanmically by Set_Up.
      Form           : ASF.Applications.Tests.Form_Bean_Access;
   end record;

   --  Cleanup the test instance.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Setup the faces context for the unit test.
   procedure Setup (T       : in out Test;
                    Context : in out Faces_Context);

   --  Test getting an attribute from the faces context.
   procedure Test_Get_Attribute (T : in out Test);

   --  Test getting a bean object from the faces context.
   procedure Test_Get_Bean (T : in out Test);

   --  Test getting a bean object from the faces context and doing a conversion.
   procedure Test_Get_Bean_Helper (T : in out Test);

   --  Test the faces message queue.
   procedure Test_Add_Message (T : in out Test);
   procedure Test_Max_Severity (T : in out Test);
   procedure Test_Get_Messages (T : in out Test);

   --  Test adding some exception in the faces context.
   procedure Test_Queue_Exception (T : in out Test);

   --  Test the flash instance.
   procedure Test_Flash_Context (T : in out Test);

   --  Test the mockup faces context.
   procedure Test_Mockup_Faces_Context (T : in out Test);

end ASF.Contexts.Faces.Tests;

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

with Util.Tests;

with EL.Contexts.Default;
with EL.Variables;

with ASF.Tests;
with ASF.Applications.Tests;
with ASF.Helpers.Beans;

package ASF.Contexts.Faces.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   function Get_Form_Bean is
     new ASF.Helpers.Beans.Get_Bean (ASF.Applications.Tests.Form_Bean,
                                     ASF.Applications.Tests.Form_Bean_Access);

   type Test is new ASF.Tests.EL_Test with record
      --  The ELContext, Variables, Resolver, Form area controlled object.
      --  Due to AUnit implementation, we cannot store a controlled object in the Test object.
      --  This is due to the 'for Obj'Address use Ret;' clause used by AUnit to allocate
      --  a test object.
      --  The application object is allocated dyanmically by Set_Up.
      Form           : ASF.Applications.Tests.Form_Bean_Access;
   end record;

   --  Cleanup the test instance.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Setup the faces context for the unit test.
   procedure Setup (T       : in out Test;
                    Context : in out Faces_Context);

   --  Test getting an attribute from the faces context.
   procedure Test_Get_Attribute (T : in out Test);

   --  Test getting a bean object from the faces context.
   procedure Test_Get_Bean (T : in out Test);

   --  Test getting a bean object from the faces context and doing a conversion.
   procedure Test_Get_Bean_Helper (T : in out Test);

   --  Test the faces message queue.
   procedure Test_Add_Message (T : in out Test);
   procedure Test_Max_Severity (T : in out Test);
   procedure Test_Get_Messages (T : in out Test);

   --  Test the application message factory for the creation of localized messages.
   procedure Test_Add_Localized_Message (T : in out Test);

   --  Test adding some exception in the faces context.
   procedure Test_Queue_Exception (T : in out Test);

   --  Test the flash instance.
   procedure Test_Flash_Context (T : in out Test);

   --  Test the mockup faces context.
   procedure Test_Mockup_Faces_Context (T : in out Test);

end ASF.Contexts.Faces.Tests;

Declare the Test_Add_Localized_Message procedure for localization test


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

package body Babel.Strategies.Default is

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean is
   begin
      return not Strategy.Queue.Directories.Is_Empty;
   end Has_Directory;

   --  Get the next directory that must be processed by the strategy.
   overriding
   function Peek_Directory (Strategy : in out Default_Strategy_Type) return String is
      Last : constant String := Strategy.Queue.Directories.Last_Element;
   begin
      Strategy.Queue.Directories.Delete_Last;
      return Last;
   end Peek_Directory;

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type) is
      Content : Babel.Files.Buffers.Buffer_Access := Strategy.Allocate_Buffer;
      File    : Babel.Files.File_Type;
      SHA1    : Util.Encoders.SHA1.Hash_Array;
   begin
      Strategy.Queue.Queue.Dequeue (File, 1.0);
      Strategy.Read_File (File, Content);
      Babel.Files.Signatures.Sha1 (Content.all, SHA1);
      Babel.Files.Set_Signature (File, SHA1);
      if Babel.Files.Is_Modified (File) then
         Strategy.Backup_File (File, Content);
      else
         Strategy.Release_Buffer (Content);
      end if;

   exception
      when others =>
         Strategy.Release_Buffer (Content);
         raise;
   end Execute;

   overriding
   procedure Add_File (Into    : in out Default_Strategy_Type;
                       Path    : in String;
                       Element : in Babel.Files.File) is
   begin
      Into.Queue.Add_File (Path, Element);
   end Add_File;

   overriding
   procedure Add_Directory (Into : in out Default_Strategy_Type;
                            Path : in String;
                            Name : in String) is
   begin
      Into.Queue.Add_Directory (Path, Name);
   end Add_Directory;

end Babel.Strategies.Default;

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

package body Babel.Strategies.Default is

   --  Returns true if there is a directory that must be processed by the current strategy.
   overriding
   function Has_Directory (Strategy : in Default_Strategy_Type) return Boolean is
   begin
      return false; --  not Strategy.Queue.Directories.Is_Empty;
   end Has_Directory;

   --  Get the next directory that must be processed by the strategy.
   overriding
   procedure Peek_Directory (Strategy  : in out Default_Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is
      Last : constant String := ""; --  Strategy.Queue.Directories.Last_Element;
   begin
      --        Strategy.Queue.Directories.Delete_Last;
      null;
   end Peek_Directory;

   overriding
   procedure Execute (Strategy : in out Default_Strategy_Type) is
      Content : Babel.Files.Buffers.Buffer_Access := Strategy.Allocate_Buffer;
      File    : Babel.Files.File_Type;
      SHA1    : Util.Encoders.SHA1.Hash_Array;
   begin
      Strategy.Queue.Queue.Dequeue (File, 1.0);
      Strategy.Read_File (File, Content);
      Babel.Files.Signatures.Sha1 (Content.all, SHA1);
      Babel.Files.Set_Signature (File, SHA1);
      if Babel.Files.Is_Modified (File) then
         Strategy.Backup_File (File, Content);
      else
         Strategy.Release_Buffer (Content);
      end if;

   exception
      when others =>
         Strategy.Release_Buffer (Content);
         raise;
   end Execute;

   --  Scan the directory
   overriding
   procedure Scan (Strategy  : in out Default_Strategy_Type;
                   Directory : in Babel.Files.Directory_Type;
                   Container : in out Babel.Files.File_Container'Class) is

      procedure Add_Queue (File : in Babel.Files.File_Type) is
      begin
         Strategy.Queue.Add_File (File);
      end Add_Queue;

   begin
      Strategy_Type (Strategy).Scan (Directory, Container);
      Container.Each_File (Add_Queue'Access);
   end Scan;

--     overriding
--     procedure Add_File (Into    : in out Default_Strategy_Type;
--                         Path    : in String;
--                         Element : in Babel.Files.File) is
--     begin
--        Into.Queue.Add_File (Path, Element);
--     end Add_File;
--
--     overriding
--     procedure Add_Directory (Into : in out Default_Strategy_Type;
--                              Path : in String;
--                              Name : in String) is
--     begin
--        Into.Queue.Add_Directory (Path, Name);
--     end Add_Directory;

end Babel.Strategies.Default;

Implement the Scan procedure

Implement the Scan procedure


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

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

   use Util.Tests;

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

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

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

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

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

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

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

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

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

      Last : Unbounded_String;

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

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

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

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

   end Test_Iterate_Path;

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

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

   function Sys_Symlink (Target : in System.Address; Link : in System.Address) return Integer
     with Import => True, Convention => C,
          Link_Name => Util.Systems.Constants.SYMBOL_PREFIX & "symlink";
   pragma Weak_External (Sys_Symlink);

   --  ------------------------------
   --  Test the Delete_Tree operation.
   --  ------------------------------
   procedure Test_Delete_Tree (T : in out Test) is
      use type System.Address;

      Path : constant String := Util.Tests.Get_Test_Path ("test-delete-tree");
   begin
      if Ada.Directories.Exists (Path) then
         Delete_Tree (Path);
      end if;

      --  Create a directory tree with symlink links that point to a non-existing file.
      Ada.Directories.Create_Directory (Path);
      for I in 1 .. 10 loop
         declare
            P : constant String := Compose (Path, Util.Strings.Image (I));
            S : String (1 .. P'Length + 3);
            R : Integer;
         begin
            Ada.Directories.Create_Directory (P);
            S (1 .. P'Length) := P;
            S (P'Length + 1) := '/';
            S (P'Length + 2) := 'A';
            S (S'Last) := ASCII.NUL;
            for J in 1 .. 5 loop
               Ada.Directories.Create_Path (Compose (P, Util.Strings.Image (J)));
            end loop;
            if Sys_Symlink'Address /= System.Null_Address then
               R := Sys_Symlink (S'Address, S'Address);
               Util.Tests.Assert_Equals (T, 0, R, "symlink creation failed");
            end if;
         end;
      end loop;
      T.Assert (Ada.Directories.Exists (Path), "Directory must exist");

      --  Ada.Directories.Delete_Tree (Path) fails to delete the tree.
      Delete_Tree (Path);
      T.Assert (not Ada.Directories.Exists (Path), "Directory must have been deleted");
   end Test_Delete_Tree;

   --  ------------------------------
   --  Test the Realpath function.
   --  ------------------------------
   procedure Test_Realpath (T : in out Test) is
      P : constant String := Util.Files.Realpath ("bin/util_harness");
   begin
      Util.Tests.Assert_Matches (T, ".*/bin/util_harness", P);
   end Test_Realpath;

end Util.Files.Tests;

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

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

   use Util.Tests;

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

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

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

   procedure Test_Read_File_Missing (T : in out Test) is
      Unused_Result : Unbounded_String;
   begin
      Read_File (Path => "regtests/files-test--util.adb", Into => Unused_Result);
      T.Assert (False, "No exception raised");
   exception
      when others =>
         null;
   end Test_Read_File_Missing;

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

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

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

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

      Last : Unbounded_String;

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

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

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

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

   end Test_Iterate_Path;

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

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

   function Sys_Symlink (Target : in System.Address; Link : in System.Address) return Integer
     with Import => True, Convention => C,
          Link_Name => Util.Systems.Constants.SYMBOL_PREFIX & "symlink";
   pragma Weak_External (Sys_Symlink);

   --  ------------------------------
   --  Test the Delete_Tree operation.
   --  ------------------------------
   procedure Test_Delete_Tree (T : in out Test) is
      use type System.Address;

      Path : constant String := Util.Tests.Get_Test_Path ("test-delete-tree");
   begin
      if Ada.Directories.Exists (Path) then
         Delete_Tree (Path);
      end if;

      --  Create a directory tree with symlink links that point to a non-existing file.
      Ada.Directories.Create_Directory (Path);
      for I in 1 .. 10 loop
         declare
            P : constant String := Compose (Path, Util.Strings.Image (I));
            S : String (1 .. P'Length + 3);
            R : Integer;
         begin
            Ada.Directories.Create_Directory (P);
            S (1 .. P'Length) := P;
            S (P'Length + 1) := '/';
            S (P'Length + 2) := 'A';
            S (S'Last) := ASCII.NUL;
            for J in 1 .. 5 loop
               Ada.Directories.Create_Path (Compose (P, Util.Strings.Image (J)));
            end loop;
            if Sys_Symlink'Address /= System.Null_Address then
               R := Sys_Symlink (S'Address, S'Address);
               Util.Tests.Assert_Equals (T, 0, R, "symlink creation failed");
            end if;
         end;
      end loop;
      T.Assert (Ada.Directories.Exists (Path), "Directory must exist");

      --  Ada.Directories.Delete_Tree (Path) fails to delete the tree.
      Delete_Tree (Path);
      T.Assert (not Ada.Directories.Exists (Path), "Directory must have been deleted");
   end Test_Delete_Tree;

   --  ------------------------------
   --  Test the Realpath function.
   --  ------------------------------
   procedure Test_Realpath (T : in out Test) is
      P : constant String := Util.Files.Realpath ("bin/util_harness");
   begin
      Util.Tests.Assert_Matches (T, ".*/bin/util_harness", P);
   end Test_Realpath;

end Util.Files.Tests;

Rename Unused_Result from Result

Rename Unused_Result from Result


------------------------------------------------------------------------------
--                                                                          --
--                    Copyright (C) 2015, AdaCore                           --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This program demonstrates use of the LIS3DSH accelerometer and a timer to
--  drive the brightness of the LEDs.

--  Note that this demonstration program is specific to the STM32F4 Discovery
--  boards because it references the specific accelerometer used on (later
--  versions of) those boards and because it references the four user LEDs
--  on those boards. (The LIS3DSH accelerometer is used on board versions
--  designated by the number MB997C printed on the top of the board.)
--
--  The idea is that the person holding the board will "pitch" it up and down
--  and "roll" it left and right around the Z axis running through the center
--  of the chip. As the board is moved, the brightness of the four LEDs
--  surrounding the accelerometer will vary with the accelerations experienced
--  by the board. In particular, as the angles increase the LEDs corresponding
--  to those sides of the board will become brighter. The LEDs will thus become
--  brightest as the board is held with any one side down, pointing toward the
--  ground.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);

with Interfaces;        use Interfaces;
with Ada.Real_Time;     use Ada.Real_Time;

with STM32.Board;       use STM32.Board;
with LIS3DSH;           use LIS3DSH;  -- on the F4 Disco board

with STM32.GPIO;        use STM32.GPIO;
with STM32.Timers;      use STM32.Timers;
with STM32.PWM;         use STM32.PWM;

use STM32;

with Demo_PWM_Settings; use Demo_PWM_Settings;

procedure Demo_LIS3DSH is

   Next_Release : Time := Clock;
   Period       : constant Time_Span := Milliseconds (100);  -- arbitrary

   function Brightness (Acceleration : Axis_Acceleration) return Percentage;
   --  Computes the output for the PWM. The approach is to compute the
   --  percentage of the given acceleration relative to a maximum acceleration
   --  of 1 G.

   procedure Drive_LEDs;
   --  Sets the pulse width for the two axes read from the accelerometer so
   --  that the brightness varies with the angle of the board.

   ----------------
   -- Brightness --
   ----------------

   function Brightness (Acceleration : Axis_Acceleration) return Percentage is
      Result          : Percentage;
      Bracketed_Value : Axis_Acceleration;
      Max_1g          : constant Axis_Acceleration := 1000;
      --  The approximate reading from the accelerometer for 1g, in
      --  milligravities, used because this demo is for a person holding the
      --  board and rotating it, so at most approximately 1g will be seen on
      --  any axis.
      --
      --  We bracket the value to the range -Max_1g .. Max_1g in order
      --  to filter out any movement beyond that of simply "pitching" and
      --  "rolling" around the Z axis running through the center of the chip.
      --  A person could move the board beyond the parameters intended for this
      --  demo simply by jerking the board laterally, for example.
   begin
      if Acceleration > 0 then
         Bracketed_Value := Axis_Acceleration'Min (Acceleration, Max_1g);
      else
         Bracketed_Value := Axis_Acceleration'Max (Acceleration, -Max_1g);
      end if;
      Result := Percentage
        ((Float (abs (Bracketed_Value)) / Float (Max_1g)) * 100.0);
      return Result;
   end Brightness;

   ----------------
   -- Drive_LEDs --
   ----------------

   procedure Drive_LEDs is
      Axes           : Axes_Accelerations;
      High_Threshold : constant Axis_Acceleration := 30;  -- arbitrary
      Low_Threshold  : constant Axis_Acceleration := -30;  -- arbitrary
      Off            : constant Percentage := 0;
   begin
      Accelerometer.Get_Accelerations (Axes);

      if Axes.X < Low_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_1, Brightness (Axes.X));
      else
         Set_Duty_Cycle (PWM_Output, Channel_1, Off);
      end if;

      if Axes.X > High_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_3, Brightness (Axes.X));
      else
         Set_Duty_Cycle (PWM_Output, Channel_3, Off);
      end if;

      if Axes.Y > High_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_2, Brightness (Axes.Y));
      else
         Set_Duty_Cycle (PWM_Output, Channel_2, Off);
      end if;

      if Axes.Y < Low_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_4, Brightness (Axes.Y));
      else
         Set_Duty_Cycle (PWM_Output, Channel_4, Off);
      end if;
   end Drive_LEDs;

begin
   Initialize_Accelerometer;

   Accelerometer.Configure
     (Output_DataRate => Data_Rate_100Hz,
      Axes_Enable     => XYZ_Enabled,
      SPI_Wire        => Serial_Interface_4Wire,
      Self_Test       => Self_Test_Normal,
      Full_Scale      => Fullscale_2g,
      Filter_BW       => Filter_800Hz);

   if Accelerometer.Device_Id /= I_Am_LIS3DSH then
      raise Program_Error with "invalid accelerometer";
   end if;

   Initialise_PWM_Modulator
     (PWM_Output,
      Requested_Frequency => PWM_Frequency,
      PWM_Timer           => PWM_Output_Timer'Access,
      PWM_AF              => PWM_Output_AF);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_1,
      Point   => Channel_1_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_2,
      Point   => Channel_2_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_3,
      Point   => Channel_3_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_4,
      Point   => Channel_4_Point);

   loop
      Drive_LEDs;

      Next_Release := Next_Release + Period;
      delay until Next_Release;
   end loop;
end Demo_LIS3DSH;

------------------------------------------------------------------------------
--                                                                          --
--                 Copyright (C) 2015-2016, AdaCore                         --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This program demonstrates use of the LIS3DSH accelerometer and a timer to
--  drive the brightness of the LEDs.

--  Note that this demonstration program is specific to the STM32F4 Discovery
--  boards because it references the specific accelerometer used on (later
--  versions of) those boards and because it references the four user LEDs
--  on those boards. (The LIS3DSH accelerometer is used on board versions
--  designated by the number MB997C printed on the top of the board.)
--
--  The idea is that the person holding the board will "pitch" it up and down
--  and "roll" it left and right around the Z axis running through the center
--  of the chip. As the board is moved, the brightness of the four LEDs
--  surrounding the accelerometer will vary with the accelerations experienced
--  by the board. In particular, as the angles increase the LEDs corresponding
--  to those sides of the board will become brighter. The LEDs will thus become
--  brightest as the board is held with any one side down, pointing toward the
--  ground.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);

with Interfaces;        use Interfaces;
with Ada.Real_Time;     use Ada.Real_Time;

with STM32.Board;       use STM32.Board;
with LIS3DSH;           use LIS3DSH;  -- on the F4 Disco board

with STM32.GPIO;        use STM32.GPIO;
with STM32.Timers;      use STM32.Timers;
with STM32.PWM;         use STM32.PWM;

use STM32;

with Demo_PWM_Settings; use Demo_PWM_Settings;

procedure Demo_LIS3DSH is

   Next_Release : Time := Clock;
   Period       : constant Time_Span := Milliseconds (100);  -- arbitrary

   function Brightness (Acceleration : Axis_Acceleration) return Percentage;
   --  Computes the output for the PWM. The approach is to compute the
   --  percentage of the given acceleration relative to a maximum acceleration
   --  of 1 G.

   procedure Drive_LEDs;
   --  Sets the pulse width for the two axes read from the accelerometer so
   --  that the brightness varies with the angle of the board.

   ----------------
   -- Brightness --
   ----------------

   function Brightness (Acceleration : Axis_Acceleration) return Percentage is
      Result          : Percentage;
      Bracketed_Value : Axis_Acceleration;
      Max_1g          : constant Axis_Acceleration := 1000;
      --  The approximate reading from the accelerometer for 1g, in
      --  milligravities, used because this demo is for a person holding the
      --  board and rotating it, so at most approximately 1g will be seen on
      --  any axis.
      --
      --  We bracket the value to the range -Max_1g .. Max_1g in order
      --  to filter out any movement beyond that of simply "pitching" and
      --  "rolling" around the Z axis running through the center of the chip.
      --  A person could move the board beyond the parameters intended for this
      --  demo simply by jerking the board laterally, for example.
   begin
      if Acceleration > 0 then
         Bracketed_Value := Axis_Acceleration'Min (Acceleration, Max_1g);
      else
         Bracketed_Value := Axis_Acceleration'Max (Acceleration, -Max_1g);
      end if;
      Result := Percentage
        ((Float (abs (Bracketed_Value)) / Float (Max_1g)) * 100.0);
      return Result;
   end Brightness;

   ----------------
   -- Drive_LEDs --
   ----------------

   procedure Drive_LEDs is
      Axes           : Axes_Accelerations;
      High_Threshold : constant Axis_Acceleration := 30;  -- arbitrary
      Low_Threshold  : constant Axis_Acceleration := -30;  -- arbitrary
      Off            : constant Percentage := 0;
   begin
      Accelerometer.Get_Accelerations (Axes);

      if Axes.X < Low_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_1, Brightness (Axes.X));
      else
         Set_Duty_Cycle (PWM_Output, Channel_1, Off);
      end if;

      if Axes.X > High_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_3, Brightness (Axes.X));
      else
         Set_Duty_Cycle (PWM_Output, Channel_3, Off);
      end if;

      if Axes.Y > High_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_2, Brightness (Axes.Y));
      else
         Set_Duty_Cycle (PWM_Output, Channel_2, Off);
      end if;

      if Axes.Y < Low_Threshold then
         Set_Duty_Cycle (PWM_Output, Channel_4, Brightness (Axes.Y));
      else
         Set_Duty_Cycle (PWM_Output, Channel_4, Off);
      end if;
   end Drive_LEDs;

begin
   Initialize_Accelerometer;

   Accelerometer.Configure
     (Output_DataRate => Data_Rate_100Hz,
      Axes_Enable     => XYZ_Enabled,
      SPI_Wire        => Serial_Interface_4Wire,
      Self_Test       => Self_Test_Normal,
      Full_Scale      => Fullscale_2g,
      Filter_BW       => Filter_800Hz);

   if Accelerometer.Device_Id /= I_Am_LIS3DSH then
      raise Program_Error with "invalid accelerometer";
   end if;

   Initialise_PWM_Modulator
     (PWM_Output,
      Requested_Frequency => PWM_Frequency,
      PWM_Timer           => PWM_Output_Timer'Access,
      PWM_AF              => PWM_Output_AF);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_1,
      Point   => Channel_1_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_2,
      Point   => Channel_2_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_3,
      Point   => Channel_3_Point);

   Attach_PWM_Channel
     (PWM_Output,
      Channel => Channel_4,
      Point   => Channel_4_Point);

   for C in Timer_Channel loop
      Enable_PWM_Channel (PWM_Output, C);
   end loop;

   loop
      Drive_LEDs;

      Next_Release := Next_Release + Period;
      delay until Next_Release;
   end loop;
end Demo_LIS3DSH;

Call new procedure to enable the PWM channels


-----------------------------------------------------------------------
--  applications-main-configs -- Configuration support for ASF Applications
--  Copyright (C) 2009, 2010, 2011, 2012, 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 EL.Contexts.Default;
with EL.Contexts.Properties;

with ASF.Contexts.Faces;
with ASF.Applications.Main;

with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package ASF.Applications.Main.Configs is

   --  Read the configuration file associated with the application.  This includes:
   --

   --
The servlet and filter mappings

   --
The managed bean definitions

   --
The navigation rules

   --

   procedure Read_Configuration (App  : in out Application'Class;
                                 File : in String);

   --  Setup the XML parser to read the managed bean definitions.
   --  By instantiating this package, the Reader gets populated with the XML mappings
   --  to read the servlet, managed beans and navigation rules.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in ASF.Contexts.Faces.Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean := False;
   package Reader_Config is
      Prop_Context : aliased EL.Contexts.Properties.Property_Resolver;
   end Reader_Config;

   --  Create the configuration parameter definition instance.
   generic
      --  The parameter name.
      Name    : in String;

      --  The default value.
      Default : in String;
   package Parameter is

      --  Returns the configuration parameter.
      function P return Config_Param;
      pragma Inline_Always (P);
   end Parameter;

   --  ------------------------------
   --  Application Specific Configuration
   --  ------------------------------
   --  Read the application specific configuration by using the XML mapper.
   --  The application configuration looks like:
   --
   --    <application>
   --      <message-bundle>name</message-bundle>
   --      <message-bundle var='name'>bundle-name</message-bundle>
   --    </application>
   --
   type Application_Config is limited record
      Name    : Util.Beans.Objects.Object;
      App     : ASF.Contexts.Faces.Application_Access;
   end record;
   type Application_Config_Access is access all Application_Config;

   type Application_Fields is (TAG_MESSAGE_BUNDLE, TAG_MESSAGE_VAR,
                               TAG_DEFAULT_LOCALE, TAG_SUPPORTED_LOCALE);

   --  Save in the application config object the value associated with the given field.
   --  When the TAG_MESSAGE_BUNDLE field is reached, insert the new bundle definition
   --  in the application.
   procedure Set_Member (N     : in out Application_Config;
                         Field : in Application_Fields;
                         Value : in Util.Beans.Objects.Object);

private

   package Application_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Application_Config,
                                               Element_Type_Access => Application_Config_Access,
                                               Fields              => Application_Fields,
                                               Set_Member          => Set_Member);

end ASF.Applications.Main.Configs;

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

with EL.Contexts.Default;
with EL.Contexts.Properties;

with ASF.Contexts.Faces;
with ASF.Applications.Main;

with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Util.Serialize.Mappers.Record_Mapper;
package ASF.Applications.Main.Configs is

   --  Read the configuration file associated with the application.  This includes:
   --

   --
The servlet and filter mappings

   --
The managed bean definitions

   --
The navigation rules

   --

   procedure Read_Configuration (App  : in out Application'Class;
                                 File : in String);

   --  Setup the XML parser to read the managed bean definitions.
   --  By instantiating this package, the Reader gets populated with the XML mappings
   --  to read the servlet, managed beans and navigation rules.
   generic
      Mapper  : in out Util.Serialize.Mappers.Processing;
      App     : in ASF.Contexts.Faces.Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean := False;
   package Reader_Config is
      Prop_Context : aliased EL.Contexts.Properties.Property_Resolver;
   end Reader_Config;

   --  Create the configuration parameter definition instance.
   generic
      --  The parameter name.
      Name    : in String;

      --  The default value.
      Default : in String;
   package Parameter is

      --  Returns the configuration parameter.
      function P return Config_Param;
      pragma Inline_Always (P);
   end Parameter;

   --  ------------------------------
   --  Application Specific Configuration
   --  ------------------------------
   --  Read the application specific configuration by using the XML mapper.
   --  The application configuration looks like:
   --
   --    <application>
   --      <message-bundle>name</message-bundle>
   --      <message-bundle var='name'>bundle-name</message-bundle>
   --    </application>
   --
   type Application_Config is limited record
      Name    : Util.Beans.Objects.Object;
      App     : ASF.Contexts.Faces.Application_Access;
   end record;
   type Application_Config_Access is access all Application_Config;

   type Application_Fields is (TAG_MESSAGE_BUNDLE, TAG_MESSAGE_VAR,
                               TAG_DEFAULT_LOCALE, TAG_SUPPORTED_LOCALE);

   --  Save in the application config object the value associated with the given field.
   --  When the TAG_MESSAGE_BUNDLE field is reached, insert the new bundle definition
   --  in the application.
   procedure Set_Member (N     : in out Application_Config;
                         Field : in Application_Fields;
                         Value : in Util.Beans.Objects.Object);

private

   package Application_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Application_Config,
                                               Element_Type_Access => Application_Config_Access,
                                               Fields              => Application_Fields,
                                               Set_Member          => Set_Member);

end ASF.Applications.Main.Configs;

Update the Reader_Config to use the new parser/mapper interface


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

with Util.Log.Loggers;

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
package body Gen.Artifacts.Distribs.Copies is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Copies");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Copy_Rule_Access := new Copy_Rule;
   begin
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "copy";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Rule, Context);

      Source : constant String := Get_First_Path (Files);
      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      Log.Info ("copy {0} to {1}", Source, Path);

      Ada.Directories.Create_Path (Dir);
      Ada.Directories.Copy_File (Source_Name => Source,
                                 Target_Name => Path,
                                 Form        => "preserve=all_attributes, mode=overwrite");
   end Install;

end Gen.Artifacts.Distribs.Copies;

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

with Util.Log.Loggers;

--  The <b>Gen.Artifacts.Distribs.Copies</b> package provides distribution rules
--  to copy a file or a directory to the distribution area.
package body Gen.Artifacts.Distribs.Copies is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Distribs.Copies");

   --  ------------------------------
   --  Create a distribution rule to copy a set of files or directories.
   --  ------------------------------
   function Create_Rule (Node : in DOM.Core.Node;
                         Copy_First_File : in Boolean) return Distrib_Rule_Access is
      pragma Unreferenced (Node);

      Result : constant Copy_Rule_Access := new Copy_Rule;
   begin
      Result.Copy_First_File := Copy_First_File;
      return Result.all'Access;
   end Create_Rule;

   --  ------------------------------
   --  Get a name to qualify the installation rule (used for logs).
   --  ------------------------------
   overriding
   function Get_Install_Name (Rule : in Copy_Rule) return String is
      pragma Unreferenced (Rule);
   begin
      return "copy";
   end Get_Install_Name;

   overriding
   procedure Install (Rule    : in Copy_Rule;
                      Path    : in String;
                      Files   : in File_Vector;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Context);
      use type Ada.Containers.Count_Type;

      Source : constant String := Get_Source_Path (Files, Rule.Copy_First_File);
      Dir    : constant String := Ada.Directories.Containing_Directory (Path);
   begin
      if Files.Length > 1 then
         Log.Info ("copy {0} to {1} (ignoring {2} files)", Source, Path,
                   Natural'Image (Natural (Files.Length) - 1));
      else
         Log.Info ("copy {0} to {1}", Source, Path);
      end if;

      Ada.Directories.Create_Path (Dir);
      Ada.Directories.Copy_File (Source_Name => Source,
                                 Target_Name => Path,
                                 Form        => "preserve=all_attributes, mode=overwrite");
   end Install;

end Gen.Artifacts.Distribs.Copies;

Add a copy-first command to copy the first file found only (the default is to copy the last one since this is the reverse search path)