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

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#2acbf#);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Stream.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

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

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#20AC#) &
        Wide_Wide_Character'Val (16#2acbf#);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Stream.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

Update the stream test

Update the stream test


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

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#20AC#) &
        Wide_Wide_Character'Val (16#2acbf#);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Stream.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Streams.Files;

package body Util.Serialize.IO.JSON.Tests is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.JSON");

   package Caller is new Util.Test_Caller (Test, "Serialize.IO.JSON");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse errors)",
                       Test_Parse_Error'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Parse (parse Ok)",
                       Test_Parser'Access);
      Caller.Add_Test (Suite, "Test Util.Serialize.IO.JSON.Write",
                       Test_Output'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check various JSON parsing errors.
   --  ------------------------------
   procedure Test_Parse_Error (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse_Error (Content : in String);

      procedure Check_Parse_Error (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);
         Log.Error ("No exception raised for: {0}", Content);

      exception
         when Parse_Error =>
            null;
      end Check_Parse_Error;

   begin
      Check_Parse_Error ("{ ""person"":23");
      Check_Parse_Error ("{ person: 23]");
      Check_Parse_Error ("[ }");
      Check_Parse_Error ("{[]}");
      Check_Parse_Error ("{");
      Check_Parse_Error ("{[");
      Check_Parse_Error ("{ ""person");
      Check_Parse_Error ("{ ""person"":");
      Check_Parse_Error ("{ ""person"":""asf");
      Check_Parse_Error ("{ ""person"":""asf""");
      Check_Parse_Error ("{ ""person"":""asf"",");
      Check_Parse_Error ("{ ""person"":""\uze""}");
      Check_Parse_Error ("{ ""person"":""\u012-""}");
      Check_Parse_Error ("{ ""person"":""\u012G""}");
   end Test_Parse_Error;

   --  ------------------------------
   --  Check various (basic) JSON valid strings (no mapper).
   --  ------------------------------
   procedure Test_Parser (T : in out Test) is
      pragma Unreferenced (T);
      procedure Check_Parse (Content : in String);

      procedure Check_Parse (Content : in String) is
         P : Parser;
      begin
         P.Parse_String (Content);

      exception
         when Parse_Error =>
            Log.Error ("Parse error for: " & Content);
            raise;
      end Check_Parse;

   begin
      Check_Parse ("{ ""person"":23}");
      Check_Parse ("{ }");
      Check_Parse ("{""person"":""asf""}");
      Check_Parse ("{""person"":""asf"",""age"":""2""}");
      Check_Parse ("{ ""person"":""\u0123""}");
      Check_Parse ("{ ""person"":""\u4567""}");
      Check_Parse ("{ ""person"":""\u89ab""}");
      Check_Parse ("{ ""person"":""\ucdef""}");
      Check_Parse ("{ ""person"":""\u1CDE""}");
      Check_Parse ("{ ""person"":""\u2ABF""}");
   end Test_Parser;

   --  ------------------------------
   --  Generate some output stream for the test.
   --  ------------------------------
   procedure Write_Stream (Stream : in out Util.Serialize.IO.Output_Stream'Class) is
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Wide : constant Wide_Wide_String :=
        Ada.Characters.Wide_Wide_Latin_1.CR &
        Ada.Characters.Wide_Wide_Latin_1.LF &
        Ada.Characters.Wide_Wide_Latin_1.HT &
        Wide_Wide_Character'Val (16#080#) &
        Wide_Wide_Character'Val (16#1fC#) &
        Wide_Wide_Character'Val (16#20AC#) & -- Euro sign
        Wide_Wide_Character'Val (16#2acbf#);
      T : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19, 23, 0, 0);
   begin
      Ada.Strings.Unbounded.Append (Name, "Katniss Everdeen");
      Stream.Start_Document;
      Stream.Start_Entity ("root");
      Stream.Start_Entity ("person");
      Stream.Write_Attribute ("id", 1);
      Stream.Write_Attribute ("name", Name);
      Stream.Write_Entity ("name", Name);
      Stream.Write_Entity ("gender", "female");
      Stream.Write_Entity ("volunteer", True);
      Stream.Write_Entity ("age", 17);
      Stream.Write_Entity ("date", T);
      Stream.Write_Wide_Entity ("skin", "olive skin");
      Stream.Start_Array ("badges");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "hunter");
      Stream.End_Entity ("badge");

      Stream.Start_Entity ("badge");
      Stream.Write_Entity ("level", "gold");
      Stream.Write_Entity ("name", "archery");
      Stream.End_Entity ("badge");
      Stream.End_Array ("badges");

      Stream.Start_Entity ("district");
      Stream.Write_Attribute ("id", 12);
      Stream.Write_Wide_Attribute ("industry", "Coal mining");
      Stream.Write_Attribute ("state", "<destroyed>");
      Stream.Write_Long_Entity ("members", 10_000);
      Stream.Write_Entity ("description", "<TBW>&""");
      Stream.Write_Wide_Entity ("wescape", "'""<>&;,@!`~[]{}^%*()-+=");
      Stream.Write_Entity ("escape", "'""<>&;,@!`~\[]{}^%*()-+=");
      Stream.Write_Wide_Entity ("wide", Wide);
      Stream.End_Entity ("district");

      Stream.End_Entity ("person");
      Stream.End_Entity ("root");
      Stream.End_Document;
   end Write_Stream;

   --  ------------------------------
   --  Test the JSON output stream generation.
   --  ------------------------------
   procedure Test_Output (T : in out Test) is
      File   : aliased Util.Streams.Files.File_Stream;
      Stream : Util.Serialize.IO.JSON.Output_Stream;
      Expect : constant String := Util.Tests.Get_Path ("regtests/expect/test-stream.json");
      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/result/test-stream.json");
   begin
      File.Create (Mode => Ada.Streams.Stream_IO.Out_File, Name => Path);
      Stream.Initialize (Output => File'Unchecked_Access, Input => null, Size => 10000);
      Write_Stream (Stream);
      Stream.Close;
      Util.Tests.Assert_Equal_Files (T       => T,
                                     Expect  => Expect,
                                     Test    => Path,
                                     Message => "JSON output serialization");
   end Test_Output;

end Util.Serialize.IO.JSON.Tests;

Add a date entry for the JSON/XML/CSV serialization test


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

--  ==  Introduction ==
--  The *workspaces* plugin defines a workspace area for other plugins.
--
--  ==  Data Model ==
--  @include Workspace.hbm.xml
--
package AWA.Workspaces is
end AWA.Workspaces;

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

--  == Introduction ==
--  The *workspaces* plugin defines a workspace area for other plugins.
--
--  == Ada Beans ==
--  @include workspaces.xml
--
--  == Data Model ==
--  @include Workspace.hbm.xml
--
package AWA.Workspaces is
end AWA.Workspaces;

Add the Ada beans in the workspace documentation


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

package body AWA.Comments.Module is

   overriding
   procedure Initialize (Plugin : in out Comment_Module;
                         App    : access ASF.Applications.Main.Application'Class) is
   begin
      null;
   end Initialize;

end AWA.Comments.Module;

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

with Util.Log.Loggers;
package body AWA.Comments.Module is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Comments.Module");

   overriding
   procedure Initialize (Plugin : in out Comment_Module;
                         App    : access ASF.Applications.Main.Application'Class) is
   begin
      Log.Info ("Initializing the comments module");

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

--        Plugin.Manager := Plugin.Create_User_Manager;
--        Register.Register (Plugin  => Plugin,
--                           Name    => "AWA.Users.Beans.Authenticate_Bean",
--                           Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App);
   end Initialize;

end AWA.Comments.Module;

Update the comments module

Update the comments module


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

with Ada.Calendar.Formatting;
with Ada.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Text_IO;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   Foreground_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 30,
      Red     => 31,
      Green   => 32,
      Yellow  => 33,
      Blue    => 34,
      Magenta => 35,
      Cyan    => 36,
      White   => 37);

   Background_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 40,
      Red     => 41,
      Green   => 42,
      Yellow  => 43,
      Blue    => 44,
      Magenta => 45,
      Cyan    => 46,
      White   => 47);

   package L renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Colorize (Text : String; Foreground, Background : Color := Default;
                      Attribute : Style := Default) return String is
      FG : constant String := Sequence (Foreground_Color_Codes (Foreground));
      BG : constant String := Sequence (Background_Color_Codes (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

   -----------------------------------------------------------------------------

   Time_Zero : constant Duration := Orka.OS.Monotonic_Clock;

   Days_Since_Zero : Natural := 0;

   function Time_Image return String is
      use Ada.Calendar.Formatting;

      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;

      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
   begin
      if Seconds_Since_Zero > Ada.Calendar.Day_Duration'Last then
         Seconds_Since_Zero := Seconds_Since_Zero - Ada.Calendar.Day_Duration'Last;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end if;
      Split (Seconds_Since_Zero, Hour, Minute, Second, Sub_Second);

      declare
         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   package Duration_IO is new Ada.Text_IO.Fixed_IO (Duration);

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));
   Last_Suffix : constant String_Access := Suffices (Suffices'Last);

   function Image (Value : Duration) return String is
      Result : String   := "-9999.999";
      Number : Duration := Value;

      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         Duration_IO.Put (Result, Item => Number, Aft => 3);
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
      return Result & " " & Suffix.all;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

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

with Ada.Calendar.Formatting;
with Ada.Characters.Latin_1;
with Ada.Strings.Fixed;
with Ada.Text_IO;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   Foreground_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 30,
      Red     => 31,
      Green   => 32,
      Yellow  => 33,
      Blue    => 34,
      Magenta => 35,
      Cyan    => 36,
      White   => 37);

   Background_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 40,
      Red     => 41,
      Green   => 42,
      Yellow  => 43,
      Blue    => 44,
      Magenta => 45,
      Cyan    => 46,
      White   => 47);

   package L renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Colorize (Text : String; Foreground, Background : Color := Default;
                      Attribute : Style := Default) return String is
      FG : constant String := Sequence (Foreground_Color_Codes (Foreground));
      BG : constant String := Sequence (Background_Color_Codes (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

   -----------------------------------------------------------------------------

   Time_Zero : constant Duration := Orka.OS.Monotonic_Clock;

   function Time_Image return String is
      use Ada.Calendar.Formatting;

      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;

      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
      Days_Since_Zero    : Natural := 0;
   begin
      while Seconds_Since_Zero > Ada.Calendar.Day_Duration'Last loop
         Seconds_Since_Zero := Seconds_Since_Zero - Ada.Calendar.Day_Duration'Last;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end loop;
      Split (Seconds_Since_Zero, Hour, Minute, Second, Sub_Second);

      declare
         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   package Duration_IO is new Ada.Text_IO.Fixed_IO (Duration);

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));
   Last_Suffix : constant String_Access := Suffices (Suffices'Last);

   function Image (Value : Duration) return String is
      Result : String   := "-9999.999";
      Number : Duration := Value;

      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         Duration_IO.Put (Result, Item => Number, Aft => 3);
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
      return Result & " " & Suffix.all;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

orka: Fix incorrect formatting in function Time_Image

If at least 24 hours or 1 day of time has elapsed, then the formatting
would be computed incorrectly because the Days_Since_Zero was
incremented and stored in a global variable.

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


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Parameters;
with Pilot;
with Unix;

procedure Ravenadm is

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;

   type mandate_type is (unset, help, dev, build, build_everything, force, test, test_everything,
                         status, status_everything, configure, locate, purge, changeopts,
                         checkports, portsnap, repository, list_subpackages, website, purgelogs);
   type dev_mandate  is (unset, dump, makefile, distinfo, buildsheet, template, genindex, web,
                         repatch, sort_plist, confinfo, genconspiracy);

   procedure scan_first_command_word;
   function scan_dev_command_word return dev_mandate;
   function get_arg (arg_number : Positive) return String;

   mandate    : mandate_type := unset;
   low_rights : Boolean := False;
   reg_user   : Boolean;
   reg_error  : constant String := "This command requires root permissions to execute.";

   procedure scan_first_command_word
   is
      first  : constant String := CLI.Argument (1);
   begin
      if first = "help" then
         mandate := help;
      elsif first = "dev" then
         mandate := dev;
      elsif first = "build" then
         mandate := build;
      elsif first = "build-everything" then
         mandate := build_everything;
      elsif first = "force" then
         mandate := force;
      elsif first = "test" then
         mandate := test;
      elsif first = "test-everything" then
         mandate := test_everything;
      elsif first = "status" then
         mandate := status;
      elsif first = "status-everything" then
         mandate := status_everything;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "locate" then
         mandate := locate;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "purge-logs" then
         mandate := purgelogs;
      elsif first = "set-options" then
         mandate := changeopts;
      elsif first = "check-ports" then
         mandate := checkports;
      elsif first = "update-ports" then
         mandate := portsnap;
      elsif first = "generate-repository" then
         mandate := repository;
      elsif first = "subpackages" then
         mandate := list_subpackages;
      elsif first = "generate-website" then
         mandate := website;
      end if;
   end scan_first_command_word;

   function scan_dev_command_word return dev_mandate
   is
      --  Check argument count before calling
      second : constant String := CLI.Argument (2);
   begin
      if second = "dump" then
         return dump;
      elsif second = "makefile" then
         return makefile;
      elsif second = "distinfo" then
         return distinfo;
      elsif second = "buildsheet" then
         return buildsheet;
      elsif second = "template" then
         return template;
      elsif second = "generate-index" then
         return genindex;
      elsif second = "generate-conspiracy" then
         return genconspiracy;
      elsif second = "web" then
         return web;
      elsif second = "repatch" then
         return repatch;
      elsif second = "sort" then
         return sort_plist;
      elsif second = "info" then
         return confinfo;
      else
         return unset;
      end if;
   end scan_dev_command_word;

   function get_arg (arg_number : Positive) return String is
   begin
      if CLI.Argument_Count >= arg_number then
         return CLI.Argument (arg_number);
      else
         return "";
      end if;
   end get_arg;

begin

   if CLI.Argument_Count = 0 then
      Pilot.display_usage;
      return;
   end if;

   scan_first_command_word;

   if mandate = unset then
      Pilot.react_to_unknown_first_level_command (CLI.Argument (1));
      return;
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block start
   --------------------------------------------------------------------------------------------

   if Pilot.already_running then
      return;
   end if;

   reg_user := Pilot.insufficient_privileges;

   if not Parameters.configuration_exists and then reg_user then
      TIO.Put_Line ("No configuration file found.");
      TIO.Put_Line ("Please switch to root permissions and retry the command.");
      return;
   end if;

   if not Parameters.load_configuration then
      return;
   end if;

   case mandate is
      when build | force | build_everything | test | status | status_everything =>
         --  All commands involving replicant slaves
         if Pilot.launch_clash_detected then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | force | build_everything | test =>
         if Parameters.configuration.avec_ncurses and then
           not Pilot.TERM_defined_in_environment
         then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when configure | help => null;
      when portsnap =>
         if not Parameters.all_paths_valid (skip_mk_check => True) then
            return;
         end if;
      when others =>
         if not Parameters.all_paths_valid (skip_mk_check => False) then
            return;
         end if;
   end case;

   case mandate is
      when help | locate | list_subpackages => null;
         low_rights := True;
      when dev =>
         declare
            dev_subcmd : dev_mandate := unset;
         begin
            if CLI.Argument_Count > 1 then
               dev_subcmd := scan_dev_command_word;
            end if;
            case dev_subcmd is
               when template | sort_plist | confinfo | unset =>
                  low_rights := True;
               when dump | makefile | distinfo | buildsheet | web | repatch |
                  genindex | genconspiracy =>
                  if reg_user then
                     TIO.Put_Line (reg_error);
                     return;
                  end if;
            end case;
         end;
      when others =>
         if reg_user then
            TIO.Put_Line (reg_error);
            return;
         end if;
   end case;

   if Pilot.previous_run_mounts_detected and then
     not Pilot.old_mounts_successfully_removed
   then
      return;
   end if;

   if Pilot.previous_realfs_work_detected and then
     not Pilot.old_realfs_work_successfully_removed
   then
      return;
   end if;

   if Pilot.ravenexec_missing then
      return;
   end if;

   case mandate is
      when build | force | test | changeopts | list_subpackages =>
         if not Pilot.store_origins (start_from => 2) then
            return;
         end if;
      when status =>
         if CLI.Argument_Count > 1 then
            if not Pilot.store_origins (start_from => 2) then
               return;
            end if;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | force |
           test | test_everything |
           status | status_everything =>
         Pilot.check_that_ravenadm_is_modern_enough;
         if not Pilot.slave_platform_determined then
            return;
         end if;
      when others => null;
   end case;

   if not low_rights then
      Pilot.create_pidfile;
      Unix.ignore_background_tty;
   end if;

   if mandate /= configure then
      Unix.cone_of_silence (deploy => True);
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block end
   --------------------------------------------------------------------------------------------

   case mandate is

      when status =>
         --------------------------------
         --  status command
         --------------------------------
         if CLI.Argument_Count > 1 then
            if Pilot.install_compiler_packages and then
              Pilot.scan_stack_of_single_ports (always_build => False) and then
              Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
            then
               Pilot.display_results_of_dry_run;
            end if;
         else
            null;  -- reserved for upgrade_system_everything maybe
         end if;

      when status_everything =>
         --------------------------------
         --  status_everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
         then
            Pilot.display_results_of_dry_run;
         end if;

      when build =>
         --------------------------------
         --  build command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when build_everything =>
         --------------------------------
         --  build-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when test_everything =>
         --------------------------------
         --  test-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => True);
         end if;

      when website =>
         --------------------------------
         --  generate-website command
         --------------------------------
         Pilot.generate_website;

      when force =>
         --------------------------------
         --  force command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when dev =>
         --------------------------------
         --  dev command
         --------------------------------
         if CLI.Argument_Count > 1 then
            declare
               dev_subcmd : dev_mandate := scan_dev_command_word;
            begin
               case dev_subcmd is
                  when unset =>
                     Pilot.react_to_unknown_second_level_command (CLI.Argument (1),
                                                                  CLI.Argument (2));
                  when dump =>
                     Pilot.dump_ravensource (get_arg (3));
                  when distinfo =>
                     Pilot.generate_distinfo;
                  when buildsheet =>
                     Pilot.generate_buildsheet (get_arg (3), get_arg (4));
                  when makefile =>
                     Pilot.generate_makefile (get_arg (3), get_arg (4));
                  when web =>
                     Pilot.generate_webpage (get_arg (3), get_arg (4));
                  when repatch =>
                     Pilot.regenerate_patches (get_arg (3), get_arg (4));
                  when sort_plist =>
                     Pilot.resort_manifests (get_arg (3));
                  when template =>
                     Pilot.print_spec_template (get_arg (3));
                  when genindex =>
                     Pilot.generate_ports_index;
                  when genconspiracy =>
                     Pilot.generate_conspiracy (get_arg (3));
                  when confinfo =>
                     Pilot.show_config_value (get_arg (3));
               end case;
            end;
         else
            Pilot.react_to_unknown_second_level_command (CLI.Argument (1), "");
         end if;

      when help =>
         --------------------------------
         --  help command
         --------------------------------
         if CLI.Argument_Count > 1 then
            Pilot.launch_man_page (CLI.Argument (2));
         else
            Pilot.show_short_help;
         end if;

      when test =>
         --------------------------------
         --  test command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => True) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            if Pilot.interact_with_single_builder then
               Pilot.bulk_run_then_interact_with_final_port;
            else
               Pilot.perform_bulk_run (testmode => True);
            end if;
         end if;

      when configure =>
         --------------------------------
         --  configure
         --------------------------------
         Pilot.launch_configure_menu;

      when locate =>
         --------------------------------
         --  locate
         --------------------------------
         Pilot.locate (get_arg (2));

      when list_subpackages =>
         --------------------------------
         --  subpackages
         --------------------------------
         Pilot.list_subpackages;

      when purge =>
         --------------------------------
         --  purge-distfiles
         --------------------------------
         Pilot.purge_distfiles;

      when purgelogs =>
         --------------------------------
         --  purge-logs
         --------------------------------
         Pilot.purge_logs;

      when changeopts =>
         --------------------------------
         --  set-options
         --------------------------------
         Pilot.change_options;

      when checkports =>
         --------------------------------
         --  check-ports
         --------------------------------
         Pilot.check_ravenports_version;

      when portsnap =>
         --------------------------------
         --  update-ports
         --------------------------------
         Pilot.update_to_latest_ravenports;

      when repository =>
         --------------------------------
         --  generate-repository
         --------------------------------
         Pilot.generate_repository;

      when unset => null;

   end case;

   Unix.cone_of_silence (deploy => False);

   if not low_rights then
      Pilot.destroy_pidfile;
   end if;

end Ravenadm;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: License.txt

with Ada.Command_Line;
with Ada.Text_IO;
with Parameters;
with Pilot;
with Unix;

procedure Ravenadm is

   package CLI renames Ada.Command_Line;
   package TIO renames Ada.Text_IO;

   type mandate_type is (unset, help, dev, build, build_everything, force, test, test_everything,
                         status, status_everything, configure, locate, purge, changeopts,
                         checkports, portsnap, repository, list_subpackages, website, purgelogs);
   type dev_mandate  is (unset, dump, makefile, distinfo, buildsheet, template, genindex, web,
                         repatch, sort_plist, confinfo, genconspiracy);

   procedure scan_first_command_word;
   function scan_dev_command_word return dev_mandate;
   function get_arg (arg_number : Positive) return String;

   mandate    : mandate_type := unset;
   low_rights : Boolean := False;
   reg_user   : Boolean;
   reg_error  : constant String := "This command requires root permissions to execute.";

   procedure scan_first_command_word
   is
      first  : constant String := CLI.Argument (1);
   begin
      if first = "help" then
         mandate := help;
      elsif first = "dev" then
         mandate := dev;
      elsif first = "build" then
         mandate := build;
      elsif first = "build-everything" then
         mandate := build_everything;
      elsif first = "force" then
         mandate := force;
      elsif first = "test" then
         mandate := test;
      elsif first = "test-everything" then
         mandate := test_everything;
      elsif first = "status" then
         mandate := status;
      elsif first = "status-everything" then
         mandate := status_everything;
      elsif first = "configure" then
         mandate := configure;
      elsif first = "locate" then
         mandate := locate;
      elsif first = "purge-distfiles" then
         mandate := purge;
      elsif first = "purge-logs" then
         mandate := purgelogs;
      elsif first = "set-options" then
         mandate := changeopts;
      elsif first = "check-ports" then
         mandate := checkports;
      elsif first = "update-ports" then
         mandate := portsnap;
      elsif first = "generate-repository" then
         mandate := repository;
      elsif first = "subpackages" then
         mandate := list_subpackages;
      elsif first = "generate-website" then
         mandate := website;
      end if;
   end scan_first_command_word;

   function scan_dev_command_word return dev_mandate
   is
      --  Check argument count before calling
      second : constant String := CLI.Argument (2);
   begin
      if second = "dump" then
         return dump;
      elsif second = "makefile" then
         return makefile;
      elsif second = "distinfo" then
         return distinfo;
      elsif second = "buildsheet" then
         return buildsheet;
      elsif second = "template" then
         return template;
      elsif second = "generate-index" then
         return genindex;
      elsif second = "generate-conspiracy" then
         return genconspiracy;
      elsif second = "web" then
         return web;
      elsif second = "repatch" then
         return repatch;
      elsif second = "sort" then
         return sort_plist;
      elsif second = "info" then
         return confinfo;
      else
         return unset;
      end if;
   end scan_dev_command_word;

   function get_arg (arg_number : Positive) return String is
   begin
      if CLI.Argument_Count >= arg_number then
         return CLI.Argument (arg_number);
      else
         return "";
      end if;
   end get_arg;

begin

   if CLI.Argument_Count = 0 then
      Pilot.display_usage;
      return;
   end if;

   scan_first_command_word;

   if mandate = unset then
      Pilot.react_to_unknown_first_level_command (CLI.Argument (1));
      return;
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block start
   --------------------------------------------------------------------------------------------

   case mandate is
      when help | locate | list_subpackages =>
         low_rights := True;
      when others =>
         if Pilot.already_running then
            return;
         end if;
   end case;

   reg_user := Pilot.insufficient_privileges;

   if not Parameters.configuration_exists and then reg_user then
      TIO.Put_Line ("No configuration file found.");
      TIO.Put_Line ("Please switch to root permissions and retry the command.");
      return;
   end if;

   if not Parameters.load_configuration then
      return;
   end if;

   case mandate is
      when build | force | build_everything | test | status | status_everything =>
         --  All commands involving replicant slaves
         if Pilot.launch_clash_detected then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | force | build_everything | test =>
         if Parameters.configuration.avec_ncurses and then
           not Pilot.TERM_defined_in_environment
         then
            return;
         end if;
      when others => null;
   end case;

   case mandate is
      when configure | help => null;
      when portsnap =>
         if not Parameters.all_paths_valid (skip_mk_check => True) then
            return;
         end if;
      when others =>
         if not Parameters.all_paths_valid (skip_mk_check => False) then
            return;
         end if;
   end case;

   case mandate is
      when help | locate | list_subpackages =>
         null;
      when dev =>
         declare
            dev_subcmd : dev_mandate := unset;
         begin
            if CLI.Argument_Count > 1 then
               dev_subcmd := scan_dev_command_word;
            end if;
            case dev_subcmd is
               when template | sort_plist | confinfo | unset =>
                  low_rights := True;
               when dump | makefile | distinfo | buildsheet | web | repatch |
                  genindex | genconspiracy =>
                  if reg_user then
                     TIO.Put_Line (reg_error);
                     return;
                  end if;
            end case;
         end;
      when others =>
         if reg_user then
            TIO.Put_Line (reg_error);
            return;
         end if;
   end case;

   if not low_rights then
      if Pilot.previous_run_mounts_detected and then
        not Pilot.old_mounts_successfully_removed
      then
         return;
      end if;

      if Pilot.previous_realfs_work_detected and then
        not Pilot.old_realfs_work_successfully_removed
      then
         return;
      end if;

      if Pilot.ravenexec_missing then
         return;
      end if;
   end if;

   case mandate is
      when build | force | test | changeopts | list_subpackages =>
         if not Pilot.store_origins (start_from => 2) then
            return;
         end if;
      when status =>
         if CLI.Argument_Count > 1 then
            if not Pilot.store_origins (start_from => 2) then
               return;
            end if;
         end if;
      when others => null;
   end case;

   case mandate is
      when build | build_everything | force |
           test | test_everything |
           status | status_everything =>
         Pilot.check_that_ravenadm_is_modern_enough;
         if not Pilot.slave_platform_determined then
            return;
         end if;
      when others => null;
   end case;

   if not low_rights then
      Pilot.create_pidfile;
      Unix.ignore_background_tty;
   end if;

   if mandate /= configure then
      Unix.cone_of_silence (deploy => True);
   end if;

   --------------------------------------------------------------------------------------------
   --  Validation block end
   --------------------------------------------------------------------------------------------

   case mandate is

      when status =>
         --------------------------------
         --  status command
         --------------------------------
         if CLI.Argument_Count > 1 then
            if Pilot.install_compiler_packages and then
              Pilot.scan_stack_of_single_ports (always_build => False) and then
              Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
            then
               Pilot.display_results_of_dry_run;
            end if;
         else
            null;  -- reserved for upgrade_system_everything maybe
         end if;

      when status_everything =>
         --------------------------------
         --  status_everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => True)
         then
            Pilot.display_results_of_dry_run;
         end if;

      when build =>
         --------------------------------
         --  build command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when build_everything =>
         --------------------------------
         --  build-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => False, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when test_everything =>
         --------------------------------
         --  test-everything command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.fully_scan_ports_tree and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => True);
         end if;

      when website =>
         --------------------------------
         --  generate-website command
         --------------------------------
         Pilot.generate_website;

      when force =>
         --------------------------------
         --  force command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => False) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            Pilot.perform_bulk_run (testmode => False);
         end if;

      when dev =>
         --------------------------------
         --  dev command
         --------------------------------
         if CLI.Argument_Count > 1 then
            declare
               dev_subcmd : dev_mandate := scan_dev_command_word;
            begin
               case dev_subcmd is
                  when unset =>
                     Pilot.react_to_unknown_second_level_command (CLI.Argument (1),
                                                                  CLI.Argument (2));
                  when dump =>
                     Pilot.dump_ravensource (get_arg (3));
                  when distinfo =>
                     Pilot.generate_distinfo;
                  when buildsheet =>
                     Pilot.generate_buildsheet (get_arg (3), get_arg (4));
                  when makefile =>
                     Pilot.generate_makefile (get_arg (3), get_arg (4));
                  when web =>
                     Pilot.generate_webpage (get_arg (3), get_arg (4));
                  when repatch =>
                     Pilot.regenerate_patches (get_arg (3), get_arg (4));
                  when sort_plist =>
                     Pilot.resort_manifests (get_arg (3));
                  when template =>
                     Pilot.print_spec_template (get_arg (3));
                  when genindex =>
                     Pilot.generate_ports_index;
                  when genconspiracy =>
                     Pilot.generate_conspiracy (get_arg (3));
                  when confinfo =>
                     Pilot.show_config_value (get_arg (3));
               end case;
            end;
         else
            Pilot.react_to_unknown_second_level_command (CLI.Argument (1), "");
         end if;

      when help =>
         --------------------------------
         --  help command
         --------------------------------
         if CLI.Argument_Count > 1 then
            Pilot.launch_man_page (CLI.Argument (2));
         else
            Pilot.show_short_help;
         end if;

      when test =>
         --------------------------------
         --  test command
         --------------------------------
         if Pilot.install_compiler_packages and then
           Pilot.scan_stack_of_single_ports (always_build => True) and then
           Pilot.sanity_check_then_prefail (delete_first => True, dry_run => False)
         then
            if Pilot.interact_with_single_builder then
               Pilot.bulk_run_then_interact_with_final_port;
            else
               Pilot.perform_bulk_run (testmode => True);
            end if;
         end if;

      when configure =>
         --------------------------------
         --  configure
         --------------------------------
         Pilot.launch_configure_menu;

      when locate =>
         --------------------------------
         --  locate
         --------------------------------
         Pilot.locate (get_arg (2));

      when list_subpackages =>
         --------------------------------
         --  subpackages
         --------------------------------
         Pilot.list_subpackages;

      when purge =>
         --------------------------------
         --  purge-distfiles
         --------------------------------
         Pilot.purge_distfiles;

      when purgelogs =>
         --------------------------------
         --  purge-logs
         --------------------------------
         Pilot.purge_logs;

      when changeopts =>
         --------------------------------
         --  set-options
         --------------------------------
         Pilot.change_options;

      when checkports =>
         --------------------------------
         --  check-ports
         --------------------------------
         Pilot.check_ravenports_version;

      when portsnap =>
         --------------------------------
         --  update-ports
         --------------------------------
         Pilot.update_to_latest_ravenports;

      when repository =>
         --------------------------------
         --  generate-repository
         --------------------------------
         Pilot.generate_repository;

      when unset => null;

   end case;

   Unix.cone_of_silence (deploy => False);

   if not low_rights then
      Pilot.destroy_pidfile;
   end if;

end Ravenadm;

Allow "ravenadm locate|help|list_subpackages" to work even if ravenadm already running elsewhere.


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

   use ADO.Statements;

   procedure Load_Table_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                                Database : in String;
                                Table    : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;

   function String_To_Type (Value : in String) return Column_Type is
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "timestamp without time zone" then
         return T_DATE_TIME;
      elsif Value = "timestamp with time zone" then
         return T_DATE_TIME;
      elsif Value = "integer" then
         return T_INTEGER;
      elsif Value = "bigint" then
         return T_LONG_INTEGER;
      elsif Value = "bytea" then
         return T_BLOB;
      elsif Value = "character varying" then
         return T_VARCHAR;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                                Database : in String;
                                Table    : in Table_Definition) is
      Name  : constant String := Get_Name (Table);
      SQL   : constant String
        := "SELECT column_name, column_default, data_type, is_nullable, "
          & "character_maximum_length, collation_name FROM information_schema.columns "
          & "WHERE table_catalog = ? AND table_name = ?";
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement (SQL));
      Last  : Column_Definition := null;
      Col   : Column_Definition;
      Value : Unbounded_String;
   begin
      Stmt.Add_Param (Database);
      Stmt.Add_Param (Name);
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (0);
         if not Stmt.Is_Null (5) then
            Col.Collation := Stmt.Get_Unbounded_String (5);
         end if;
         if not Stmt.Is_Null (1) then
            Col.Default   := Stmt.Get_Unbounded_String (1);
         end if;
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (2);
         Col.Col_Type := String_To_Type (To_String (Value));

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "YES";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema   : out Schema_Definition;
                          Database : in String) is
      SQL   : constant String
        := "SELECT tablename FROM pg_catalog.pg_tables "
          & "WHERE schemaname != 'pg_catalog' AND schemaname != 'information_schema'";
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement (SQL));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Database, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Postgresql;

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

   use ADO.Statements;

   procedure Load_Table_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                                Database : in String;
                                Table    : in Table_Definition);

   procedure Load_Table_Keys (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                              Database : in String;
                              Table    : in Table_Definition);

   function String_To_Type (Value : in String) return Column_Type;

   function String_To_Type (Value : in String) return Column_Type is
   begin
      if Value = "date" then
         return T_DATE;
      elsif Value = "timestamp without time zone" then
         return T_DATE_TIME;
      elsif Value = "timestamp with time zone" then
         return T_DATE_TIME;
      elsif Value = "integer" then
         return T_INTEGER;
      elsif Value = "bigint" then
         return T_LONG_INTEGER;
      elsif Value = "bytea" then
         return T_BLOB;
      elsif Value = "character varying" then
         return T_VARCHAR;
      end if;
      return T_UNKNOWN;
   end String_To_Type;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                                Database : in String;
                                Table    : in Table_Definition) is
      Name  : constant String := Get_Name (Table);
      SQL   : constant String
        := "SELECT column_name, column_default, data_type, is_nullable, "
          & "character_maximum_length, collation_name FROM information_schema.columns "
          & "WHERE table_catalog = ? AND table_name = ?";
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement (SQL));
      Last  : Column_Definition := null;
      Col   : Column_Definition;
      Value : Unbounded_String;
   begin
      Stmt.Add_Param (Database);
      Stmt.Add_Param (Name);
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Col           := new Column;
         Col.Name      := Stmt.Get_Unbounded_String (0);
         if not Stmt.Is_Null (5) then
            Col.Collation := Stmt.Get_Unbounded_String (5);
         end if;
         if not Stmt.Is_Null (1) then
            Col.Default   := Stmt.Get_Unbounded_String (1);
         end if;
         if Last /= null then
            Last.Next_Column := Col;
         else
            Table.First_Column := Col;
         end if;

         Value := Stmt.Get_Unbounded_String (2);
         Col.Col_Type := String_To_Type (To_String (Value));

         Value := Stmt.Get_Unbounded_String (3);
         Col.Is_Null := Value = "YES";

         Last := Col;
         Stmt.Next;
      end loop;
   end Load_Table_Schema;

   --  ------------------------------
   --  Load the table definition
   --  ------------------------------
   procedure Load_Table_Keys (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                              Database : in String;
                              Table    : in Table_Definition) is
      Name  : constant String := Get_Name (Table);
      SQL   : constant String
        := "SELECT column_name FROM"
        & " information_schema.table_constraints tc, "
        & " information_schema.key_column_usage kc "
        & "WHERE tc.constraint_type = 'PRIMARY KEY' "
        & " AND kc.table_name = tc.table_name "
        & " AND kc.table_schema = tc.table_schema "
        & " AND kc.constraint_name = tc.constraint_name "
        & " AND tc.table_catalog = ? and tc.table_name = ?";
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement (SQL));
      Col   : Column_Definition;
   begin
      Stmt.Add_Param (Database);
      Stmt.Add_Param (Name);
      Stmt.Execute;
      while Stmt.Has_Elements loop
         declare
            Col_Name : constant String := Stmt.Get_String (0);
         begin
            Col := Find_Column (Table, Col_Name);
            if Col /= null then
               Col.Is_Primary := True;
            end if;
         end;

         Stmt.Next;
      end loop;
   end Load_Table_Keys;

   --  ------------------------------
   --  Load the database schema
   --  ------------------------------
   procedure Load_Schema (C        : in ADO.Drivers.Connections.Database_Connection'Class;
                          Schema   : out Schema_Definition;
                          Database : in String) is
      SQL   : constant String
        := "SELECT tablename FROM pg_catalog.pg_tables "
          & "WHERE schemaname != 'pg_catalog' AND schemaname != 'information_schema'";
      Stmt  : Query_Statement
        := Create.Create_Statement (C.Create_Statement (SQL));
      Table : Table_Definition;
      Last  : Table_Definition := null;
   begin
      Schema.Schema := new ADO.Schemas.Schema;
      Stmt.Execute;

      while Stmt.Has_Elements loop
         Table      := new ADO.Schemas.Table;
         Table.Name := Stmt.Get_Unbounded_String (0);
         if Last /= null then
            Last.Next_Table := Table;
         else
            Schema.Schema.First_Table := Table;
         end if;
         Load_Table_Schema (C, Database, Table);
         Load_Table_Keys (C, Database, Table);
         Last := Table;
         Stmt.Next;
      end loop;
   end Load_Schema;

end ADO.Schemas.Postgresql;

Declare and implement Load_Table_Keys to find the primary keys and set the Is_Primary attribute for columns