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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
with MAT.Readers.Streams.Sockets;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
   Server  : MAT.Readers.Streams.Sockets.Socket_Listener_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Target.Start;
   MAT.Commands.Interactive (Target);
   Server.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Server.Stop;
end Matp;

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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Target.Start;
   MAT.Commands.Interactive (Target);
   Target.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Target.Stop;
end Matp;

Use the MAT.Targets.Stop operation

Use the MAT.Targets.Stop operation


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

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Unbounded_Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := Link;
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Unbounded_Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := Link;
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Nodes.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      Wiki.Nodes.Iterate (List, Process'Access);
   end Render;

end Wiki.Render;

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

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Unbounded_Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := Link;
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Nodes.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      Wiki.Nodes.Iterate (List, Process'Access);
   end Render;

   --  ------------------------------
   --  Render the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Nodes.Document) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;
   begin
      Wiki.Nodes.Iterate (Doc, Process'Access);
   end Render;

end Wiki.Render;

Implement the Render procedure on a Document


-----------------------------------------------------------------------
--  wiki-helpers -- Helper operations for wiki parsers and renderer
--  Copyright (C) 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.Wide_Wide_Characters.Handling;
package body Wiki.Helpers is

   --  ------------------------------
   --  Returns True if the character is a space or tab.
   --  ------------------------------
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Space (C) or C = HT;
   end Is_Space;

   --  ------------------------------
   --  Returns True if the character is a space, tab or a newline.
   --  ------------------------------
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Is_Space (C) or Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Space_Or_Newline;

   --  ------------------------------
   --  Returns True if the character is a line terminator.
   --  ------------------------------
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Newline;

   --  ------------------------------
   --  Returns True if the text is a valid URL
   --  ------------------------------
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean is
   begin
      if Text'Length <= 9 then
         return False;
      else
         return Text (Text'First .. Text'First + 6) = "http://"
           or Text (Text'First .. Text'First + 7) = "https://";
      end if;
   end Is_Url;

   --  ------------------------------
   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   --  ------------------------------
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean is
      S : constant Wiki.Strings.WString := Ada.Wide_Wide_Characters.Handling.To_Lower (Ext);
   begin
      return S = ".png" or S = ".jpg" or S = ".gif" or S = ".jpeg";
   end Is_Image_Extension;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original           -> Width, Height := Natural'Last
   --    default            -> Width := 800, Height := 0
   --    upright            -> Width := 800, Height := 0
   --    <width>px          -> Width := <width>, Height := 0
   --    x<height>px        -> Width := 0, Height := <height>
   --    <width>x<height>px -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in Wiki.Strings.WString;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos  : Natural;
      Last : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" or Dimension = "upright" then
         Width  := 800;
         Height := 0;
      else
         Pos  := Wiki.Strings.Index (Dimension, "x");
         Last := Wiki.Strings.Index (Dimension, "px");
         if Pos > Dimension'First and Last + 1 /= Pos then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Pos - 1));
         elsif Last > 0 then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Last - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Wide_Wide_Value (Dimension (Pos + 1 .. Last - 1));
         else
            Height := 0;
         end if;
      end if;

   exception
      when Constraint_Error =>
         Width  := 0;
         Height := 0;
   end Get_Sizes;

end Wiki.Helpers;

-----------------------------------------------------------------------
--  wiki-helpers -- Helper operations for wiki parsers and renderer
--  Copyright (C) 2016, 2020 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.Wide_Wide_Characters.Handling;
package body Wiki.Helpers is

   --  ------------------------------
   --  Returns True if the character is a space or tab.
   --  ------------------------------
   function Is_Space (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Space (C) or C = HT or C = NBSP;
   end Is_Space;

   --  ------------------------------
   --  Returns True if the character is a space, tab or a newline.
   --  ------------------------------
   function Is_Space_Or_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Is_Space (C) or Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Space_Or_Newline;

   --  ------------------------------
   --  Returns True if the character is a line terminator.
   --  ------------------------------
   function Is_Newline (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return Ada.Wide_Wide_Characters.Handling.Is_Line_Terminator (C);
   end Is_Newline;

   --  ------------------------------
   --  Returns True if the text is a valid URL
   --  ------------------------------
   function Is_Url (Text : in Wiki.Strings.WString) return Boolean is
   begin
      if Text'Length <= 9 then
         return False;
      else
         return Text (Text'First .. Text'First + 6) = "http://"
           or Text (Text'First .. Text'First + 7) = "https://";
      end if;
   end Is_Url;

   --  ------------------------------
   --  Returns True if the extension part correspond to an image.
   --  Recognized extension are: .png, .gif, .jpg, .jpeg.
   --  The extension case is ignored.
   --  ------------------------------
   function Is_Image_Extension (Ext : in Wiki.Strings.WString) return Boolean is
      S : constant Wiki.Strings.WString := Ada.Wide_Wide_Characters.Handling.To_Lower (Ext);
   begin
      return S = ".png" or S = ".jpg" or S = ".gif" or S = ".jpeg";
   end Is_Image_Extension;

   --  ------------------------------
   --  Given the current tag on the top of the stack and the new tag that will be pushed,
   --  decide whether the current tag must be closed or not.
   --  Returns True if the current tag must be closed.
   --  ------------------------------
   function Need_Close (Tag         : in Html_Tag;
                        Current_Tag : in Html_Tag) return Boolean is
   begin
      if No_End_Tag (Current_Tag) then
         return True;
      elsif Current_Tag = Tag and Tag_Omission (Current_Tag) then
         return True;
      else
         case Current_Tag is
            when DT_TAG | DD_TAG =>
               return Tag = DD_TAG or Tag = DL_TAG or Tag = DT_TAG;

            when TD_TAG =>
               return Tag = TD_TAG or Tag = TR_TAG or Tag = TH_TAG;

            when TR_TAG =>
               return False;

            when others =>
               return False;

         end case;
      end if;
   end Need_Close;

   --  ------------------------------
   --  Get the dimension represented by the string.  The string has one of the following
   --  formats:
   --    original           -> Width, Height := Natural'Last
   --    default            -> Width := 800, Height := 0
   --    upright            -> Width := 800, Height := 0
   --    <width>px          -> Width := <width>, Height := 0
   --    x<height>px        -> Width := 0, Height := <height>
   --    <width>x<height>px -> Width := <width>, Height := <height>
   --  ------------------------------
   procedure Get_Sizes (Dimension : in Wiki.Strings.WString;
                        Width     : out Natural;
                        Height    : out Natural) is
      Pos  : Natural;
      Last : Natural;
   begin
      if Dimension = "original" then
         Width  := Natural'Last;
         Height := Natural'Last;
      elsif Dimension = "default" or Dimension = "upright" then
         Width  := 800;
         Height := 0;
      else
         Pos  := Wiki.Strings.Index (Dimension, "x");
         Last := Wiki.Strings.Index (Dimension, "px");
         if Pos > Dimension'First and Last + 1 /= Pos then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Pos - 1));
         elsif Last > 0 then
            Width := Natural'Wide_Wide_Value (Dimension (Dimension'First .. Last - 1));
         else
            Width := 0;
         end if;
         if Pos < Dimension'Last then
            Height := Natural'Wide_Wide_Value (Dimension (Pos + 1 .. Last - 1));
         else
            Height := 0;
         end if;
      end if;

   exception
      when Constraint_Error =>
         Width  := 0;
         Height := 0;
   end Get_Sizes;

end Wiki.Helpers;

Update Is_Space so that the   is treated as a space


-----------------------------------------------------------------------
--  serialize-io-json-tests -- Unit tests for JSON parser
--  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.Test_Caller;
with Util.Log.Loggers;

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);
   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"",");
   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""}");
   end Test_Parser;

end Util.Serialize.IO.JSON.Tests;

-----------------------------------------------------------------------
--  serialize-io-json-tests -- Unit tests for JSON parser
--  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.Test_Caller;
with Util.Log.Loggers;

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);
   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"",");
   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""}");
   end Test_Parser;

end Util.Serialize.IO.JSON.Tests;

Add a test case for json

Add a test case for json


-----------------------------------------------------------------------
--  awa-wikis-documents -- Wiki 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 Ada.Strings.Wide_Wide_Unbounded;

package AWA.Wikis.Documents is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Format_Type is (BOLD, ITALIC, CODE, SUPERSCRIPT, SUBSCRIPT, STRIKEOUT, PREFORMAT);

   type Format_Map is array (Format_Type) of Boolean;

   --  ------------------------------
   --  Document reader
   --  ------------------------------
   type Document_Reader is limited interface;
   type Document_Reader_Access is access all Document_Reader'Class;

   --  Add a section header in the document.
   procedure Add_Header (Document : in out Document_Reader;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive) is abstract;

   --  Add a line break (
).
   procedure Add_Line_Break (Document : in out Document_Reader) is abstract;

   --  Add a paragraph (
).  Close the previous paragraph if any.
   --  The paragraph must be closed at the next paragraph or next header.
   procedure Add_Paragraph (Document : in out Document_Reader) is abstract;

   --  Add a list item (
).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Document_Reader;
                            Level    : in Positive;
                            Ordered  : in Boolean) is abstract;

   --  Add an horizontal rule (
).
   procedure Add_Horizontal_Rule (Document : in out Document_Reader) is abstract;

   --  Add a link.
   procedure Add_Link (Document : in out Document_Reader;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is abstract;

   --  Add an image.
   procedure Add_Image (Document    : in out Document_Reader;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is abstract;

   --  Add a quote.
   procedure Add_Quote (Document : in out Document_Reader;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is abstract;

   --  Add a text block with the given format.
   procedure Add_Text (Document : in out Document_Reader;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Format_Map) is abstract;

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Document_Reader;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is abstract;

   --  Finish the document after complete wiki text has been parsed.
   procedure Finish (Document : in out Document_Reader) is abstract;

end AWA.Wikis.Documents;

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

package AWA.Wikis.Documents is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Format_Type is (BOLD, ITALIC, CODE, SUPERSCRIPT, SUBSCRIPT, STRIKEOUT, PREFORMAT);

   type Format_Map is array (Format_Type) of Boolean;

   --  ------------------------------
   --  Document reader
   --  ------------------------------
   type Document_Reader is limited interface;
   type Document_Reader_Access is access all Document_Reader'Class;

   --  Add a section header in the document.
   procedure Add_Header (Document : in out Document_Reader;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive) is abstract;

   --  Add a line break (
).
   procedure Add_Line_Break (Document : in out Document_Reader) is abstract;

   --  Add a paragraph (
).  Close the previous paragraph if any.
   --  The paragraph must be closed at the next paragraph or next header.
   procedure Add_Paragraph (Document : in out Document_Reader) is abstract;

   --  Add a blockquote (
).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Document_Reader;
                             Level    : in Natural) is abstract;

   --  Add a list item (
).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Document_Reader;
                            Level    : in Positive;
                            Ordered  : in Boolean) is abstract;

   --  Add an horizontal rule (
).
   procedure Add_Horizontal_Rule (Document : in out Document_Reader) is abstract;

   --  Add a link.
   procedure Add_Link (Document : in out Document_Reader;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is abstract;

   --  Add an image.
   procedure Add_Image (Document    : in out Document_Reader;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is abstract;

   --  Add a quote.
   procedure Add_Quote (Document : in out Document_Reader;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is abstract;

   --  Add a text block with the given format.
   procedure Add_Text (Document : in out Document_Reader;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Format_Map) is abstract;

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Document_Reader;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is abstract;

   --  Finish the document after complete wiki text has been parsed.
   procedure Finish (Document : in out Document_Reader) is abstract;

end AWA.Wikis.Documents;

Declare the Add_Blockquote procedure

Declare the Add_Blockquote procedure


-----------------------------------------------------------------------
--  Util.Beans.Objects.Discrete_Tests - Generic simple test for discrete object types
--  Copyright (C) 2009, 2010, 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 Ada.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;

with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;
   use Util.Tests;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

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

with Ada.Containers;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Ada.Calendar;

with Util.Test_Caller;
with Util.Beans.Objects.Hash;
package body Util.Beans.Objects.Discrete_Tests is

   use Ada.Strings.Fixed;
   use Ada.Containers;

   procedure Test_Eq (T : Test; V : String; N : Test_Type);
   procedure Test_Conversion (T : Test; V : String; N : Test_Type);
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type);
   procedure Test_Sub (T : Test; V : String; N : Test_Type);
   procedure Test_Add (T : Test; V : String; N : Test_Type);
   procedure Test_Perf (T : Test; V : String; N : Test_Type);
   procedure Test_Hash (T : in out Test);

   --  Generic test for To_Object and To_XXX types
   --  Several values are specified in the Test_Values string.
   generic
      with procedure Basic_Test (T : in Test; V : String; N : Test_Type);
   procedure Test_Basic_Object (T : in out Test);

   procedure Test_Basic_Object (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next : Natural;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V : constant String := Test_Values (Pos .. Next - 1);
            N : constant Test_Type := Value (V);
         begin
            Basic_Test (T, V, N);
         end;
         Pos := Next + 1;
      end loop;
   end Test_Basic_Object;

   --  ------------------------------
   --  Test Util.Beans.Objects.To_Object
   --  ------------------------------
   procedure Test_Conversion (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object (V);
      T.Assert (Condition => To_Type (Value) = N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);

      T.Assert (Condition => V = To_String (Value),
                Message   => Test_Name & ".To_String returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Conversion;
   procedure Test_To_Object is new Test_Basic_Object (Basic_Test => Test_Conversion);

   --  ------------------------------
   --  Test Util.Beans.Objects.Hash
   --  ------------------------------
   procedure Test_Hash (T : in out Test) is
      pragma Unmodified (T);

      Pos, Next   : Natural;
      Hash_Values : array (Test_Values'Range) of Hash_Type := (others => 0);
      Nb_Hash     : Natural := 0;
   begin
      Pos := Test_Values'First;
      while Pos <= Test_Values'Last loop
         Next := Index (Test_Values, ",", Pos);
         if Next < Pos then
            Next := Test_Values'Last + 1;
         end if;
         declare
            V     : constant String := Test_Values (Pos .. Next - 1);
            N     : constant Test_Type := Value (V);
            Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
            H     : constant Hash_Type := Util.Beans.Objects.Hash (Value);
            Found : Boolean := False;
         begin
            for J in 1 .. Nb_Hash loop
               if Hash_Values (J) = H then
                  Found := True;
               end if;
            end loop;
            if not Found then
               Nb_Hash := Nb_Hash + 1;
               Hash_Values (Nb_Hash) := H;
            end if;
         end;
         Pos := Next + 1;
      end loop;

      Ada.Text_IO.Put_Line ("Found " & Natural'Image (Nb_Hash) & " hash values");
      T.Assert (Nb_Hash > 1, "Only one hash value found");
   end Test_Hash;

   --  ------------------------------
   --  Test Util.Beans.Objects."+"
   --  ------------------------------
   procedure Test_Add (T : Test; V : String; N : Test_Type) is
      Value : Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Value := Value + To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N + N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: " & V);
   end Test_Add;

   procedure Test_Add is new Test_Basic_Object (Test_Add);

   --  ------------------------------
   --  Test Util.Beans.Objects."-"
   --  ------------------------------
   procedure Test_Sub (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (V);

      Value : Util.Beans.Objects.Object;
   begin
      Value := To_Object_Test (N) - To_Object_Test (N);
      T.Assert (Condition => To_Type (Value) = N - N,
                Message   => Test_Name & " returned invalid value: "
                & To_String (Value) & " when we expected: 0");
   end Test_Sub;

   procedure Test_Sub is new Test_Basic_Object (Test_Sub);

   --  ------------------------------
   --  Test Util.Beans.Objects."<" and Util.Beans.Objects.">"
   --  ------------------------------
   procedure Test_Lt_Gt (T : Test; V : String; N : Test_Type) is
      Res    : Boolean;
      Is_Neg : constant Boolean := Index (V, "-") = V'First;
      O      : constant Util.Beans.Objects.Object := To_Object_Test (N);
   begin
      Res := To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) > To_Object_Test (N);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: false");
      Res := To_Object_Test (N) + To_Object_Test (N) < To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'<' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V & "Num=" & Long_Long_Integer'Image (To_Long_Long_Integer (O))
                & " Sum=" & Long_Long_Integer'Image (To_Long_Long_Integer (O + O)));
      Res := To_Object_Test (N) > To_Object_Test (N) + To_Object_Test (N);
      T.Assert (Condition => Res = Is_Neg,
                Message   => Test_Name & ".'>' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: "
                & Boolean'Image (Is_Neg)
                & " with value: " & V);
      if V /= "0" and V /= "false" and V /= "true" then
         Res := To_Object_Test (N) < To_Object_Test (N) + To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'<' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
         Res := To_Object_Test (N) + To_Object_Test (N) > To_Object_Test (N);
         T.Assert (Condition => Res = not Is_Neg,
                   Message   => Test_Name & ".'>' returned invalid value: "
                   & Boolean'Image (Res) & " when we expected: "
                   & Boolean'Image (not Is_Neg)
                   & " with value: " & V);
      end if;
   end Test_Lt_Gt;

   procedure Test_Lt_Gt is new Test_Basic_Object (Test_Lt_Gt);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Eq (T : Test; V : String; N : Test_Type) is
      Res   : Boolean;
   begin
      Res := To_Object_Test (N) = To_Object_Test (N);
      T.Assert (Condition => Res,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " when we expected: true");

      Res := To_Object_Test (N) = To_Object ("Something" & V);
      T.Assert (Condition => Res = False,
                Message   => Test_Name & ".'=' returned invalid value: "
                & Boolean'Image (Res) & " where we expected: False");
   end Test_Eq;
   procedure Test_Eq is new Test_Basic_Object (Test_Eq);

   --  ------------------------------
   --  Test Util.Beans.Objects."="
   --  ------------------------------
   procedure Test_Perf (T : Test; V : String; N : Test_Type) is
      pragma Unreferenced (T, V);

      use Ada.Calendar;

      Start : Ada.Calendar.Time;
      Value : constant Util.Beans.Objects.Object := To_Object_Test (N);
      D     : Duration;
   begin
      Start := Ada.Calendar.Clock;
      for I in 1 .. 1_000 loop
         declare
            V : Util.Beans.Objects.Object := Value;
         begin
            V := V + V;

            pragma Unreferenced (V);
         end;
      end loop;
      D := Ada.Calendar.Clock - Start;
      Ada.Text_IO.Put_Line ("Perf " & Test_Name & ": " & Duration'Image (D * 1000.0));
   end Test_Perf;
   procedure Test_Perf is new Test_Basic_Object (Test_Perf);

   package Caller is new Util.Test_Caller (Test, "Objects." & Test_Name);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_Object." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.To_String." & Test_Name,
                       Test_To_Object'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'='." & Test_Name,
                       Test_Eq'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'+'." & Test_Name,
                       Test_Add'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'-'." & Test_Name,
                       Test_Sub'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'<'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.'>'." & Test_Name,
                       Test_Lt_Gt'Access);
      Caller.Add_Test (Suite, "Performance Util.Beans.Objects.'>'." & Test_Name,
                       Test_Perf'Access);
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Hash." & Test_Name,
                       Test_Hash'Access);
   end Add_Tests;

end Util.Beans.Objects.Discrete_Tests;

Remove unused use Util.Tests clause

Remove unused use Util.Tests clause


------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 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 the copyright holder 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.   --
--                                                                          --
------------------------------------------------------------------------------

package MicroBit is
end MicroBit;

------------------------------------------------------------------------------
--                                                                          --
--                       Copyright (C) 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 the copyright holder 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.   --
--                                                                          --
------------------------------------------------------------------------------

with nRF51.Device;
with nRF51.GPIO;

package MicroBit is

   MB_P0  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P03;  --  0 pad on edge connector
   MB_P1  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P02;  --  1 pad on edge connector
   MB_P2  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P01;  --  2 pad on edge connector
   MB_P3  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P04;  --  Display column 1
   MB_P4  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P05;  --  Display column 2
   MB_P5  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P17;  --  Button A
   MB_P6  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P12;  --  Display column 9
   MB_P7  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P11;  --  Display column 8
   MB_P8  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P18;
   MB_P9  : nRF51.GPIO.GPIO_Point renames nRF51.Device.P10;  --  Display column 7
   MB_P10 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P06;  --  Display column 3
   MB_P11 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P26;  --  Button B
   MB_P12 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P20;
   MB_P13 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P23;  --  SCK
   MB_P14 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P22;  --  MISO
   MB_P15 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P21;  --  MOSI
   MB_P16 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P16;
   MB_P19 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P00;  --  SCL
   MB_P20 : nRF51.GPIO.GPIO_Point renames nRF51.Device.P30;  --  SDA
end MicroBit;

Define MicroBit pins

MicroBit: Define MicroBit pins


-----------------------------------------------------------------------
--  awa-storages-services-tests -- Unit tests for storage service
--  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.Streams;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Storages.Modules;
with AWA.Storages.Beans.Factories;
with AWA.Tests.Helpers.Users;
package body AWA.Storages.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Save",
                       Test_Create_Storage'Access);
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Delete",
                       Test_Delete_Storage'Access);
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Save_Folder, Folder_Bean",
                       Test_Create_Folder'Access);

   end Add_Tests;

   --  ------------------------------
   --  Save something in a storage element and keep track of the store id in the test Id.
   --  ------------------------------
   procedure Save (T : in out Test) is
      Store     : AWA.Storages.Models.Storage_Ref;
   begin
      T.Manager := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (T.Manager /= null, "Null storage manager");

      T.Manager.Save (Into    => Store,
                      Path    => "Makefile",
                      Storage => AWA.Storages.Models.DATABASE);
      T.Assert (not Store.Is_Null, "Storage object should not be null");
      T.Id := Store.Get_Id;
      T.Assert (T.Id > 0, "Invalid storage identifier");
   end Save;

   --  ------------------------------
   --  Load the storage element refered to by the test Id.
   --  ------------------------------
   procedure Load (T : in out Test) is
      use type Ada.Streams.Stream_Element_Offset;

      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Mime      : Ada.Strings.Unbounded.Unbounded_String;
      Date      : Ada.Calendar.Time;
      Data      : ADO.Blob_Ref;
   begin
      T.Manager := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (T.Manager /= null, "Null storage manager");

      T.Manager.Load (From => T.Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
      T.Assert (not Data.Is_Null, "Null blob returned by load");
      T.Assert (Data.Value.Len > 100, "Invalid length for the blob data");
   end Load;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Storage (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Save;
      T.Load;
   end Test_Create_Storage;

   --  ------------------------------
   --  Test deletion of a storage object
   --  ------------------------------
   procedure Test_Delete_Storage (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Data      : ADO.Blob_Ref;
      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Mime      : Ada.Strings.Unbounded.Unbounded_String;
      Date      : Ada.Calendar.Time;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Save;
      T.Manager.Delete (T.Id);
      T.Manager.Load (From => T.Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
      T.Assert (Data.Is_Null, "A non null blob returned by load");
   end Test_Delete_Storage;

   --  ------------------------------
   --  Test creation of a storage folder
   --  ------------------------------
   procedure Test_Create_Folder (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Folder    : AWA.Storages.Beans.Factories.Folder_Bean;
      Outcome   : Ada.Strings.Unbounded.Unbounded_String;
      Folder2   : AWA.Storages.Beans.Factories.Folder_Bean;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      Folder.Set_Name ("Test folder name");
      Folder.Module := AWA.Storages.Modules.Get_Storage_Module;
      Folder.Save (Outcome);
      Util.Tests.Assert_Equals (T, "success", Outcome, "Invalid outcome returned by Save action");

      Folder2.Set_Value ("folderId", ADO.Objects.To_Object (Folder.Get_Key));
      Util.Tests.Assert_Equals (T, "Test folder name", String '(Folder2.Get_Name),
                                "Invalid folder name");
   end Test_Create_Folder;

end AWA.Storages.Services.Tests;

-----------------------------------------------------------------------
--  awa-storages-services-tests -- Unit tests for storage service
--  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.Streams;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Storages.Modules;
with AWA.Storages.Beans.Factories;
with AWA.Tests.Helpers.Users;
package body AWA.Storages.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Save",
                       Test_Create_Storage'Access);
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Delete",
                       Test_Delete_Storage'Access);
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Save_Folder, Folder_Bean",
                       Test_Create_Folder'Access);

   end Add_Tests;

   --  ------------------------------
   --  Save something in a storage element and keep track of the store id in the test Id.
   --  ------------------------------
   procedure Save (T : in out Test) is
      Store     : AWA.Storages.Models.Storage_Ref;
   begin
      T.Manager := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (T.Manager /= null, "Null storage manager");

      T.Manager.Save (Into    => Store,
                      Path    => "Makefile",
                      Storage => AWA.Storages.Models.DATABASE);
      T.Assert (not Store.Is_Null, "Storage object should not be null");
      T.Id := Store.Get_Id;
      T.Assert (T.Id > 0, "Invalid storage identifier");
   end Save;

   --  ------------------------------
   --  Load the storage element refered to by the test Id.
   --  ------------------------------
   procedure Load (T : in out Test) is
      use type Ada.Streams.Stream_Element_Offset;

      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Mime      : Ada.Strings.Unbounded.Unbounded_String;
      Date      : Ada.Calendar.Time;
      Data      : ADO.Blob_Ref;
   begin
      T.Manager := AWA.Storages.Modules.Get_Storage_Manager;
      T.Assert (T.Manager /= null, "Null storage manager");

      T.Manager.Load (From => T.Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
      T.Assert (not Data.Is_Null, "Null blob returned by load");
      T.Assert (Data.Value.Len > 100, "Invalid length for the blob data");
   end Load;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Storage (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Save;
      T.Load;
   end Test_Create_Storage;

   --  ------------------------------
   --  Test deletion of a storage object
   --  ------------------------------
   procedure Test_Delete_Storage (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Data      : ADO.Blob_Ref;
      Name      : Ada.Strings.Unbounded.Unbounded_String;
      Mime      : Ada.Strings.Unbounded.Unbounded_String;
      Date      : Ada.Calendar.Time;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Save;
      T.Manager.Delete (T.Id);
      begin
         T.Manager.Load (From => T.Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
         T.Assert (False, "No exception raised");

      exception
         when ADO.Objects.NOT_FOUND =>
            null;
      end;
   end Test_Delete_Storage;

   --  ------------------------------
   --  Test creation of a storage folder
   --  ------------------------------
   procedure Test_Create_Folder (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Folder    : AWA.Storages.Beans.Factories.Folder_Bean;
      Outcome   : Ada.Strings.Unbounded.Unbounded_String;
      Upload    : AWA.Storages.Beans.Factories.Upload_Bean;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      Folder.Module := AWA.Storages.Modules.Get_Storage_Module;
      Upload.Module := AWA.Storages.Modules.Get_Storage_Module;

      Folder.Set_Name ("Test folder name");
      Folder.Save (Outcome);
      Util.Tests.Assert_Equals (T, "success", Outcome, "Invalid outcome returned by Save action");

      Upload.Set_Value ("folderId", ADO.Objects.To_Object (Folder.Get_Key));
      Util.Tests.Assert_Equals (T, "Test folder name", String '(Upload.Get_Folder.Get_Name),
                                "Invalid folder name");
   end Test_Create_Folder;

end AWA.Storages.Services.Tests;

Fix storage unit test

Fix storage unit test


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

with Utilities;
with Ada.Characters.Latin_1;

package body Port_Specification.Json is

   package UTL renames Utilities;
   package LAT renames Ada.Characters.Latin_1;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := escape_tagline (specs.get_tagline (varstr));
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  escape_tagline
   --------------------------------------------------------------------------------------------
   function escape_tagline (raw : String) return String
   is
      focus : constant String :=
        LAT.Reverse_Solidus &
        LAT.Quotation &
        LAT.Solidus &
        LAT.BS &
        LAT.FF &
        LAT.LF &
        LAT.CR &
        LAT.HT;
      curlen : Natural := raw'Length;
      result : String (1 .. raw'Length * 2) := (others => ' ');
   begin
      result (1 .. curlen) := raw;
      for x in focus'Range loop
         if HT.count_char (result (1 .. curlen), focus (x)) > 0 then
            declare
               newstr : String := HT.replace_char (result (1 .. curlen), focus (x),
                                                   LAT.Reverse_Solidus & focus (x));
            begin
               curlen := newstr'Length;
               result (1 .. curlen) := newstr;
            end;
         end if;
      end loop;
      return result (1 .. curlen);
   end escape_tagline;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object (product, vendor : String) return String;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      function form_object (product, vendor : String) return String
      is
         data1 : String := UTL.json_nvpair_string ("product", product, 1, 0);  -- trailing LF
         data2 : String := UTL.json_nvpair_string ("vendor", vendor, 1, 0);    -- trailing LF
      begin
         return "{ " & data1 (data1'First .. data1'Last - 1) & ", "
                     & data2 (data2'First .. data2'Last - 1) & "}";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         return UTL.json_nvpair_complex ("cpe", form_object (cpe_product, cpe_vendor), 3, pad);
      end;
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

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

with Utilities;
with Ada.Characters.Latin_1;

package body Port_Specification.Json is

   package UTL renames Utilities;
   package LAT renames Ada.Characters.Latin_1;

   --------------------------------------------------------------------------------------------
   --  describe_port
   --------------------------------------------------------------------------------------------
   procedure describe_port
     (specs   : Portspecs;
      dossier : TIO.File_Type;
      bucket  : String;
      index   : Positive)
   is
      fpcval : constant String := fpc_value (specs.generated, specs.equivalent_fpc_port);
      nvar   : constant Natural := specs.get_number_of_variants;
   begin
      TIO.Put
        (dossier,
           UTL.json_object (True, 3, index) &
           UTL.json_nvpair_string  ("bucket",   bucket, 1, pad) &
           UTL.json_nvpair_string  ("namebase", specs.get_namebase, 2, pad) &
           UTL.json_nvpair_string  ("version",  specs.get_field_value (sp_version), 3, pad) &
           homepage_line (specs) &
           UTL.json_nvpair_string  ("FPC",      fpcval, 3, pad) &
           UTL.json_nvpair_complex ("keywords", describe_keywords (specs), 3, pad) &
           UTL.json_nvpair_complex ("distfile", describe_distfiles (specs), 3, pad) &
           specs.get_json_contacts &
           describe_Common_Platform_Enumeration (specs) &
           UTL.json_name_complex   ("variants", 4, pad) &
           UTL.json_array (True, pad + 1)
        );
      for x in 1 .. nvar loop
         declare
            varstr : constant String := specs.get_list_item (Port_Specification.sp_variants, x);
            sdesc  : constant String := escape_tagline (specs.get_tagline (varstr));
            spray  : constant String := describe_subpackages (specs, varstr);
         begin
            TIO.Put
              (dossier,
               UTL.json_object (True, pad + 2, x) &
                 UTL.json_nvpair_string  ("label", varstr, 1, pad + 3) &
                 UTL.json_nvpair_string  ("sdesc", sdesc, 2, pad + 3) &
                 UTL.json_nvpair_complex ("spkgs", spray, 3, pad + 3) &
                 UTL.json_object (False, pad + 2, x)
              );
         end;
      end loop;
      TIO.Put
        (dossier,
           UTL.json_array (False, pad + 1) &
           UTL.json_object (False, 3, index)
        );

   end describe_port;

   --------------------------------------------------------------------------------------------
   --  fpc_value
   --------------------------------------------------------------------------------------------
   function fpc_value (is_generated : Boolean; raw_value : String) return String is
   begin
      if is_generated then
         return "generated";
      else
         return raw_value;
      end if;
   end fpc_value;

   --------------------------------------------------------------------------------------------
   --  describe_keywords
   --------------------------------------------------------------------------------------------
   function describe_keywords (specs : Portspecs) return String
   is
      raw : constant String := specs.get_field_value (Port_Specification.sp_keywords);
      innerquote : constant String :=
        HT.replace_char
          (S         => HT.replace_char (raw, LAT.Comma, LAT.Quotation & LAT.Comma),
           focus     => LAT.Space,
           substring => LAT.Space & LAT.Quotation);
   begin
      return "[ " & LAT.Quotation & innerquote  & LAT.Quotation & " ]";
   end describe_keywords;

   --------------------------------------------------------------------------------------------
   --  describe_distfiles
   --------------------------------------------------------------------------------------------
   function describe_distfiles (specs : Portspecs) return String
   is
      numfiles : constant Natural := specs.get_list_length (Port_Specification.sp_distfiles);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numfiles loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation & specs.get_repology_distfile (x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_distfiles;

   --------------------------------------------------------------------------------------------
   --  describe_subpackages
   --------------------------------------------------------------------------------------------
   function describe_subpackages (specs : Portspecs; variant : String) return String
   is
      numpkg : constant Natural := specs.get_subpackage_length (variant);
      result   : HT.Text := HT.SUS ("[ ");
   begin
      for x in 1 .. numpkg loop
         if x > 1 then
            HT.SU.Append (result, ", ");
         end if;
         HT.SU.Append (result, LAT.Quotation &
                         specs.get_subpackage_item (variant, x) & LAT.Quotation);
      end loop;
      return HT.USS (result) & " ]";
   end describe_subpackages;

   --------------------------------------------------------------------------------------------
   --  escape_tagline
   --------------------------------------------------------------------------------------------
   function escape_tagline (raw : String) return String
   is
      focus : constant String :=
        LAT.Reverse_Solidus &
        LAT.Quotation &
        LAT.Solidus &
        LAT.BS &
        LAT.FF &
        LAT.LF &
        LAT.CR &
        LAT.HT;
      curlen : Natural := raw'Length;
      result : String (1 .. raw'Length * 2) := (others => ' ');
   begin
      result (1 .. curlen) := raw;
      for x in focus'Range loop
         if HT.count_char (result (1 .. curlen), focus (x)) > 0 then
            declare
               newstr : String := HT.replace_char (result (1 .. curlen), focus (x),
                                                   LAT.Reverse_Solidus & focus (x));
            begin
               curlen := newstr'Length;
               result (1 .. curlen) := newstr;
            end;
         end if;
      end loop;
      return result (1 .. curlen);
   end escape_tagline;

   --------------------------------------------------------------------------------------------
   --  homepage_line
   --------------------------------------------------------------------------------------------
   function homepage_line (specs : Portspecs) return String
   is
      homepage : constant String := specs.get_field_value (sp_homepage);
   begin
      if homepage = homepage_none or else
        specs.repology_sucks
      then
         return "";
      end if;
      return UTL.json_nvpair_string  ("homepage", specs.get_field_value (sp_homepage), 3, pad);
   end homepage_line;

   --------------------------------------------------------------------------------------------
   --  describe_Common_Platform_Enumeration
   --------------------------------------------------------------------------------------------
   function describe_Common_Platform_Enumeration (specs : Portspecs) return String
   is
      function retrieve (key : String; default_value : String) return String;
      function form_object (product, vendor : String) return String;

      function retrieve (key : String; default_value : String) return String
      is
         key_text : HT.Text := HT.SUS (key);
      begin
         if specs.catch_all.Contains (key_text) then
            return HT.USS (specs.catch_all.Element (key_text).list.First_Element);
         else
            return default_value;
         end if;
      end retrieve;

      function form_object (product, vendor : String) return String
      is
         data1 : String := UTL.json_nvpair_string ("product", product, 1, 0);  -- trailing LF
         data2 : String := UTL.json_nvpair_string ("vendor", vendor, 1, 0);    -- trailing LF
      begin
         return "{" & data1 (data1'First .. data1'Last - 1) & LAT.Comma
                     & data2 (data2'First .. data2'Last - 1) & " }";
      end form_object;
   begin
      if not specs.uses.Contains (HT.SUS ("cpe")) then
         return "";
      end if;

      declare
         cpe_product : String := retrieve ("CPE_PRODUCT", HT.lowercase (specs.get_namebase));
         cpe_vendor  : String := retrieve ("CPE_VENDOR", cpe_product);
      begin
         return UTL.json_nvpair_complex ("cpe", form_object (cpe_product, cpe_vendor), 3, pad);
      end;
   end describe_Common_Platform_Enumeration;

end Port_Specification.Json;

Fix spacing on cpe json

Fix spacing on cpe json