DELETED natools-accumulators-string_accumulator_linked_lists.adb Index: natools-accumulators-string_accumulator_linked_lists.adb ================================================================== --- natools-accumulators-string_accumulator_linked_lists.adb +++ natools-accumulators-string_accumulator_linked_lists.adb @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -package body Natools.Accumulators.String_Accumulator_Linked_Lists is - - procedure Initialize_If_Needed - (Object : in out String_Accumulator_Linked_List) is - begin - if Object.Stack.Is_Empty then - Object.Stack.Append (Object.Build (1)); - Object.Position := Object.Stack.Last; - end if; - end Initialize_If_Needed; - - - - procedure Append (To : in out String_Accumulator_Linked_List; - Text : String) - is - procedure Process (Element : in out String_Accumulator'Class); - - procedure Process (Element : in out String_Accumulator'Class) is - begin - Element.Append (Text); - end Process; - begin - Initialize_If_Needed (To); - To.Stack.Update_Element (To.Position, Process'Access); - end Append; - - - - procedure Hard_Reset (Acc : in out String_Accumulator_Linked_List) is - begin - Acc.Stack.Clear; - Acc.Position := Lists.No_Element; - end Hard_Reset; - - - - function Length (Acc : String_Accumulator_Linked_List) return Natural is - procedure Process (Element : String_Accumulator'Class); - - Result : Natural; - - procedure Process (Element : String_Accumulator'Class) is - begin - Result := Element.Length; - end Process; - begin - if Acc.Stack.Is_Empty then - return 0; - else - Lists.Query_Element (Acc.Position, Process'Access); - return Result; - end if; - end Length; - - - - procedure Push (Acc : in out String_Accumulator_Linked_List) is - procedure Process (Element : in out String_Accumulator'Class); - - use type Lists.Cursor; - - procedure Process (Element : in out String_Accumulator'Class) is - begin - Soft_Reset (Element); - end Process; - begin - Initialize_If_Needed (Acc); - Lists.Next (Acc.Position); - if Acc.Position = Lists.No_Element then - declare - Level_Created : constant Positive - := Natural (Acc.Stack.Length) + 1; - begin - Acc.Stack.Append (Acc.Build (Level_Created)); - Acc.Position := Acc.Stack.Last; - end; - else - Acc.Stack.Update_Element (Acc.Position, Process'Access); - end if; - end Push; - - - - procedure Pop (Acc : in out String_Accumulator_Linked_List) is - use type Lists.Cursor; - begin - if Acc.Stack.Is_Empty then - raise Program_Error; - end if; - Lists.Previous (Acc.Position); - if Acc.Position = Lists.No_Element then - Acc.Position := Lists.First (Acc.Stack); - raise Program_Error; - end if; - end Pop; - - - - procedure Soft_Reset (Acc : in out String_Accumulator_Linked_List) is - procedure Process (Element : in out String_Accumulator'Class); - - procedure Process (Element : in out String_Accumulator'Class) is - begin - Element.Soft_Reset; - end Process; - begin - Initialize_If_Needed (Acc); - Acc.Position := Lists.First (Acc.Stack); - Acc.Stack.Update_Element (Acc.Position, Process'Access); - end Soft_Reset; - - - - function Tail (Acc : String_Accumulator_Linked_List; Size : Natural) - return String - is - procedure Process (Element : String_Accumulator'Class); - - Result : String (1 .. Size); - Actual_Size : Natural; - - procedure Process (Element : String_Accumulator'Class) - is - Output : constant String := Tail (Element, Size); - begin - Actual_Size := Output'Length; - Result (1 .. Actual_Size) := Output; - end Process; - begin - if Acc.Stack.Is_Empty then - return ""; - else - Lists.Query_Element (Acc.Position, Process'Access); - return Result (1 .. Actual_Size); - end if; - end Tail; - - - - function To_String (Acc : String_Accumulator_Linked_List) return String is - begin - if Acc.Stack.Is_Empty then - return ""; - end if; - - declare - procedure Process (Element : String_Accumulator'Class); - - Result : String (1 .. Acc.Length); - - procedure Process (Element : String_Accumulator'Class) is - begin - Result := Element.To_String; - end Process; - begin - Lists.Query_Element (Acc.Position, Process'Access); - return Result; - end; - end To_String; - - - - procedure To_String (Acc : String_Accumulator_Linked_List; - Output : out String) is - begin - if Acc.Stack.Is_Empty then - return; - end if; - - declare - procedure Process (Element : String_Accumulator'Class); - - procedure Process (Element : String_Accumulator'Class) is - begin - Element.To_String (Output); - end Process; - begin - Lists.Query_Element (Acc.Position, Process'Access); - end; - end To_String; - - - - procedure Unappend (From : in out String_Accumulator_Linked_List; - Text : String) - is - procedure Process (Element : in out String_Accumulator'Class); - - procedure Process (Element : in out String_Accumulator'Class) is - begin - Element.Unappend (Text); - end Process; - begin - if not From.Stack.Is_Empty then - From.Stack.Update_Element (From.Position, Process'Access); - end if; - end Unappend; - -end Natools.Accumulators.String_Accumulator_Linked_Lists; DELETED natools-accumulators-string_accumulator_linked_lists.ads Index: natools-accumulators-string_accumulator_linked_lists.ads ================================================================== --- natools-accumulators-string_accumulator_linked_lists.ads +++ natools-accumulators-string_accumulator_linked_lists.ads @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Accumulators.String_Accumulator_Linked_Lists is a simple -- --- implementation of String_Accumulator_Stack using an external function to -- --- generate the String_Accumulator elements when the stack is grown. -- ------------------------------------------------------------------------------- - -private with Ada.Containers.Indefinite_Doubly_Linked_Lists; - -package Natools.Accumulators.String_Accumulator_Linked_Lists is - pragma Preelaborate (String_Accumulator_Linked_Lists); - - type String_Accumulator_Linked_List - (Build : not null access function (Depth : Positive) - return String_Accumulator'Class) - is new String_Accumulator_Stack with private; - - procedure Append (To : in out String_Accumulator_Linked_List; - Text : String); - -- Append the given String to the internal buffer - - procedure Hard_Reset (Acc : in out String_Accumulator_Linked_List); - -- Empty the internal buffer and free all possible memory - - function Length (Acc : String_Accumulator_Linked_List) return Natural; - -- Return the length of the internal buffer - - procedure Push (Acc : in out String_Accumulator_Linked_List); - -- Push the current internal buffer and start with an empty one - - procedure Pop (Acc : in out String_Accumulator_Linked_List); - -- Drop the current internal buffer and use the previsouly pushed one - -- instead - -- Raise Program_Error when trying to pop the last internal buffer - - procedure Soft_Reset (Acc : in out String_Accumulator_Linked_List); - -- Empty the internal buffer for reuse - - function Tail (Acc : String_Accumulator_Linked_List; Size : Natural) - return String; - -- Return the last characters from the internal buffer - - function To_String (Acc : String_Accumulator_Linked_List) return String; - -- Output the whole internal buffer as a String - - procedure To_String (Acc : String_Accumulator_Linked_List; - Output : out String); - -- Write the whole internal buffer into the String, which must be - -- large enough. - - procedure Unappend (From : in out String_Accumulator_Linked_List; - Text : String); - -- Remove the given suffix from the internal buffer - -- Do nothing if the given text is not a prefix the internal buffer - -private - - package Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists - (Element_Type => String_Accumulator'Class); - - type String_Accumulator_Linked_List - (Build : not null access function (Depth : Positive) - return String_Accumulator'Class) - is new String_Accumulator_Stack with - record - Stack : Lists.List; - Position : Lists.Cursor; - end record; - - procedure Initialize_If_Needed - (Object : in out String_Accumulator_Linked_List); - -end Natools.Accumulators.String_Accumulator_Linked_Lists; DELETED natools-accumulators.ads Index: natools-accumulators.ads ================================================================== --- natools-accumulators.ads +++ natools-accumulators.ads @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Accumulators is a collection of interfaces for data structures -- --- that allow efficient accumulation of data. -- --- -- --- String_Accumulator is meant for creation of long strings through -- --- repeated calls of Append, and later retrieval of the full buffer through -- --- one of the To_String subprograms. Length, Tail and Unappend are -- --- helper utilities that might not be very efficient but can occasionnally -- --- be useful. Hard_Reset and Soft_Reset both clear the internal state, with -- --- Soft_Reset aimed for speed while Hard_Reset aims for best memory release -- --- -- --- String_Accumulator_Stack adds a stack structure on top of -- --- String_Accumulator, to allow temporary substrings to be created using -- --- similar facilities. All operations on String_Accumulator except -- --- Hard_Reset and Soft_Reset, when applied to String_Accumulator_Stack, are -- --- meant to be forwarded to the top accumulator of the stack. Push and Pop -- --- change the stack state, while Hard_Reset and Soft_Reset apply to the -- --- whole stack, with the same semantics as for String_Accumulator. -- ------------------------------------------------------------------------------- - -package Natools.Accumulators is - pragma Pure (Accumulators); - - type String_Accumulator is interface; - - procedure Append (To : in out String_Accumulator; Text : String) - is abstract; - -- Append the given String to the internal buffer - - procedure Hard_Reset (Acc : in out String_Accumulator) - is abstract; - -- Empty the internal buffer and free all possible memory - - function Length (Acc : String_Accumulator) return Natural - is abstract; - -- Return the length of the internal buffer - - procedure Soft_Reset (Acc : in out String_Accumulator) - is abstract; - -- Empty the internal buffer for reuse - - function Tail (Acc : String_Accumulator; Size : Natural) return String - is abstract; - -- Return the last characters from the internal buffer - - function To_String (Acc : String_Accumulator) return String - is abstract; - -- Output the whole internal buffer as a String - - procedure To_String (Acc : String_Accumulator; Output : out String) - is abstract; - -- Write the whole internal buffer into the String, which must be - -- large enough. - - procedure Unappend (From : in out String_Accumulator; Text : String) - is abstract; - -- Remove the given suffix from the internal buffer - -- Do nothing if the given text is not a prefix the internal buffer - - - - type String_Accumulator_Stack is interface and String_Accumulator; - - procedure Push (Acc : in out String_Accumulator_Stack) - is abstract; - -- Push the current internal buffer and start with an empty one - - procedure Pop (Acc : in out String_Accumulator_Stack) - is abstract; - -- Drop the current internal buffer and use the previsouly pushed one - -- instead - -- Raise Program_Error when trying to pop the last internal buffer - -end Natools.Accumulators; DELETED natools-chunked_strings-tests-cxa4010.adb Index: natools-chunked_strings-tests-cxa4010.adb ================================================================== --- natools-chunked_strings-tests-cxa4010.adb +++ natools-chunked_strings-tests-cxa4010.adb @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Strings; use Ada.Strings; - -procedure Natools.Chunked_Strings.Tests.CXA4010 - (Report : in out Natools.Tests.Reporter'Class) is -begin - Natools.Tests.Section (Report, "Port of ACATS CXA4010"); - - declare - - Pamphlet_Paragraph_Count : constant := 2; - Lines : constant := 4; - Line_Length : constant := 40; - - type Document_Type is array (Positive range <>) of Chunked_String; - - type Camera_Ready_Copy_Type is - array (1 .. Lines) of String (1 .. Line_Length); - - procedure Enter_Text_Into_Document (Document : in out Document_Type); - procedure Create_Camera_Ready_Copy - (Document : in Document_Type; - Camera_Copy : out Camera_Ready_Copy_Type); - procedure Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type); - - Pamphlet : Document_Type (1 .. Pamphlet_Paragraph_Count); - Camera_Ready_Copy : Camera_Ready_Copy_Type := - (others => (others => Ada.Strings.Space)); - TC_Finished_Product : constant Camera_Ready_Copy_Type := - (1 => "Ada is a programming language designed ", - 2 => "to support long-lived, reliable software", - 3 => " systems. ", - 4 => "Go with Ada! "); - - - procedure Enter_Text_Into_Document (Document : in out Document_Type) is - begin - Document (1) := To_Chunked_String ("Ada is a language"); - Document (1) := Insert (Document (1), - Index (Document (1), "language"), - To_String ("progra" - & Chunked_Strings."*" (2, 'm') - & "ing ")); - Document (1) := - Overwrite (Document (1), - Index (Document (1), - To_String (Tail (Document (1), 8, ' ')), - Ada.Strings.Backward), - "language designed to support long-lifed"); - Document (1) := - Overwrite (Document (1), - Index (Document (1), - To_String (Tail (Document (1), 5, ' ')), - Ada.Strings.Backward), - "lived, reliable software systems."); - Document (2) := 'G' - & To_Chunked_String ("o ") - & To_Chunked_String ("with") - & ' ' - & "Ada!"; - end Enter_Text_Into_Document; - - - procedure Create_Camera_Ready_Copy - (Document : in Document_Type; - Camera_Copy : out Camera_Ready_Copy_Type) is - begin - Camera_Copy (1) := - Slice (Document (1), - 1, - Index (To_Chunked_String (Slice (Document (1), - 1, Line_Length)), - Ada.Strings.Maps.To_Set (' '), - Ada.Strings.Inside, - Ada.Strings.Backward)) - & ' '; - Camera_Copy (2) := - Slice (Document (1), - 40, - Index_Non_Blank (To_Chunked_String (Slice (Document (1), - 40, 79)), - Ada.Strings.Backward) + 39); - Camera_Copy (3) (1 .. 9) := - Slice (Document (1), 80, Length (Document (1))); - Camera_Copy (4) (1 .. Length (Document (2))) := - To_String (Head (Document (2), Length (Document (2)))); - end Create_Camera_Ready_Copy; - - - procedure Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) is - begin - for I in Draft'Range loop - declare - Name : constant String := "Slice" & Positive'Image (I); - begin - if Draft (I) = Master (I) then - Natools.Tests.Item (Report, Name, Natools.Tests.Success); - else - Natools.Tests.Item (Report, Name, Natools.Tests.Fail); - Natools.Tests.Info (Report, "Draft: """ & Draft (I) & '"'); - Natools.Tests.Info (Report, "Master: """ & Master (I) & '"'); - end if; - exception - when Error : others => - Natools.Tests.Report_Exception (Report, Name, Error); - end; - end loop; - end Valid_Proofread; - begin - Enter_Text_Into_Document (Pamphlet); - Create_Camera_Ready_Copy (Document => Pamphlet, - Camera_Copy => Camera_Ready_Copy); - Valid_Proofread (Draft => Camera_Ready_Copy, - Master => TC_Finished_Product); - exception - when Error : others => - Natools.Tests.Report_Exception (Report, "Preparation", Error); - end; - - Natools.Tests.End_Section (Report); - -end Natools.Chunked_Strings.Tests.CXA4010; DELETED natools-chunked_strings-tests-cxa4010.ads Index: natools-chunked_strings-tests-cxa4010.ads ================================================================== --- natools-chunked_strings-tests-cxa4010.ads +++ natools-chunked_strings-tests-cxa4010.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests.CXA4010 is the transcription to -- --- Chunked_String of ACATS test CXA4010 for Unbounded_String. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic procedure Natools.Chunked_Strings.Tests.CXA4010 - (Report : in out Natools.Tests.Reporter'Class); -pragma Preelaborate (CXA4010); DELETED natools-chunked_strings-tests-cxa4011.adb Index: natools-chunked_strings-tests-cxa4011.adb ================================================================== --- natools-chunked_strings-tests-cxa4011.adb +++ natools-chunked_strings-tests-cxa4011.adb @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Strings; use Ada.Strings; - -procedure Natools.Chunked_Strings.Tests.CXA4011 - (Report : in out Natools.Tests.Reporter'Class) -is - package NT renames Natools.Tests; - - procedure Test (Test_Name : String; - C_1 : Character; - C_2 : Character; - Name_1 : String; - Name_2 : String); - - - procedure Test (Test_Name : String; - C_1 : Character; - C_2 : Character; - Name_1 : String; - Name_2 : String) is - begin - if C_1 = C_2 then - NT.Item (Report, Test_Name, NT.Success); - else - NT.Item (Report, Test_Name, NT.Fail); - NT.Info (Report, Name_1 & ": " & Character'Image (C_1)); - NT.Info (Report, Name_2 & ": " & Character'Image (C_2)); - end if; - end Test; -begin - NT.Section (Report, "Port of ACATS CXA4011"); - - declare - Cad_String : constant Chunked_String - := To_Chunked_String ("cad"); - Complete_String : constant Chunked_String - := To_Chunked_String ("Incomplete") - & Ada.Strings.Space - & To_Chunked_String ("String"); - Incomplete_String : Chunked_String - := To_Chunked_String ("ncomplete Strin"); - Incorrect_Spelling : Chunked_String - := To_Chunked_String ("Guob Dai"); - Magic_String : constant Chunked_String - := To_Chunked_String ("abracadabra"); - Incantation : Chunked_String := Magic_String; - - A_Small_G : constant Character := 'g'; - A_Small_D : constant Character := 'd'; - - ABCD_Set : constant Maps.Character_Set := Maps.To_Set ("abcd"); - B_Set : constant Maps.Character_Set := Maps.To_Set ("b"); - AB_Set : constant Maps.Character_Set - := Maps."OR" (Maps.To_Set ('a'), B_Set); - - Code_Map : constant Maps.Character_Mapping - := Maps.To_Mapping (From => "abcd", To => "wxyz"); - Reverse_Code_Map : constant Maps.Character_Mapping - := Maps.To_Mapping (From => "wxyz", To => "abcd"); - Non_Existent_Map : constant Maps.Character_Mapping - := Maps.To_Mapping (From => "jkl", To => "mno"); - - Token_Start : array (1 .. 3) of Positive; - Token_End : array (1 .. 3) of Natural := (0, 0, 0); - Matching_Letters : Natural := 0; - - Tests : array (1 .. 5) of Boolean; - begin - declare - Name : constant String := "Operator ""&"""; - Tests : array (1 .. 3) of Boolean; - begin - Incomplete_String := 'I' & Incomplete_String; - Incomplete_String := Incomplete_String & A_Small_G; - if not Is_Valid (Incomplete_String) - or not Is_Valid (Complete_String) then - NT.Item (Report, Name, NT.Error); - if not Is_Valid (Incomplete_String) then - NT.Info (Report, "Incomplete_String is invalid"); - end if; - if not Is_Valid (Complete_String) then - NT.Info (Report, "Complete_String is invalid"); - end if; - else - Tests (1) := Incomplete_String < Complete_String; - Tests (2) := Incomplete_String > Complete_String; - Tests (3) := Incomplete_String /= Complete_String; - if Tests (1) or Tests (2) or Tests (3) then - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Incomplete_String: """ - & To_String (Incomplete_String) & '"'); - NT.Info (Report, "Complete_String: """ - & To_String (Complete_String) & '"'); - if Tests (1) then - NT.Info (Report, "-> Incomplete_String < Complete_String"); - end if; - if Tests (2) then - NT.Info (Report, "-> Incomplete_String < Complete_String"); - end if; - if Tests (3) then - NT.Info (Report, "-> Incomplete_String /= Complete_String"); - end if; - else - NT.Item (Report, Name, NT.Success); - end if; - end if; - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - NT.Section (Report, "Function Element"); - - declare - Name : constant String := "Element of complete vs constant"; - begin - Test (Name, - Element (Incomplete_String, Length (Incomplete_String)), - A_Small_G, - "Element (""" & To_String (Incomplete_String) - & ',' & Natural'Image (Length (Incomplete_String)) & ')', - "A_Small_G"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Element of complete vs Element of Tail"; - begin - Test (Name, - Element (Incomplete_String, 2), - Element (Tail (Incomplete_String, 2), 1), - "Element (""" & To_String (Incomplete_String) & ", 2)", - "Element (""" & To_String (Tail (Incomplete_String, 2)) - & ", 1)"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Element of Head vs Element of constant"; - begin - Test (Name, - Element (Head (Incomplete_String, 4), 2), - Element (To_Chunked_String ("wnqz"), 2), - "Element (""" & To_String (Head (Incomplete_String, 4)) - & ", 2)", - "Element (""wnqz"", 2)"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - declare - Name : constant String := "Procedure Replace_Element"; - begin - Replace_Element (Incorrect_Spelling, 2, 'o'); - Replace_Element (Incorrect_Spelling, - Index (Incorrect_Spelling, B_Set), - A_Small_D); - Replace_Element (Source => Incorrect_Spelling, - Index => Length (Incorrect_Spelling), - By => 'y'); - Test (Report, Name, Incorrect_Spelling, "Good Day"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - -- Function Count - Matching_Letters := Count (Source => Magic_String, - Set => ABCD_Set); - NT.Item (Report, "Function Count with Set parameter", - NT.To_Result (Matching_Letters = 9)); - if Matching_Letters /= 9 then - NT.Info - (Report, - "Count (""" & To_String (Magic_String) & """, ABCD_Set) " - & Natural'Image (Matching_Letters) - & " (should be 9)"); - Dump (Report, Magic_String); - end if; - Tests (1) := Count (Magic_String, "ab") - = Count (Magic_String, "ac") + Count (Magic_String, "ad"); - Tests (2) := Count (Magic_String, "ab") = 2; - NT.Item (Report, "Function Count with String parameter", - NT.To_Result (Tests (1) and Tests (2))); - if not Tests (1) or not Tests (2) then - NT.Info - (Report, - "Count (""" & To_String (Magic_String) & """, ""ab"") " - & Natural'Image (Count (Magic_String, "ab")) - & " (should be 2)"); - NT.Info - (Report, - "Count (""" & To_String (Magic_String) & """, ""ac"") " - & Natural'Image (Count (Magic_String, "ac"))); - NT.Info - (Report, - "Count (""" & To_String (Magic_String) & """, ""ad"") " - & Natural'Image (Count (Magic_String, "ad"))); - end if; - - -- Find_Token - Find_Token (Magic_String, - AB_Set, - Ada.Strings.Inside, - Token_Start (1), - Token_End (1)); - Tests (1) := Natural (Token_Start (1)) = To_String (Magic_String)'First - and Token_End (1) = Index (Magic_String, B_Set); - Find_Token (Source => Magic_String, - Set => ABCD_Set, - Test => Ada.Strings.Outside, - First => Token_Start (2), - Last => Token_End (2)); - Tests (2) := Natural (Token_Start (2)) = 3 and Token_End (2) = 3; - Find_Token (Magic_String, - Maps.To_Set (A_Small_G), - Ada.Strings.Inside, - First => Token_Start (3), - Last => Token_End (3)); - Tests (3) := Token_Start (3) = To_String (Magic_String)'First - and Token_End (3) = 0; - NT.Item (Report, "Procedure Find_Token", - NT.To_Result (Tests (1) and Tests (2) and Tests (3))); - if not Tests (1) then - NT.Info (Report, - "Start: " - & Positive'Image (Token_Start (1)) & " /= " - & Positive'Image (To_String (Magic_String)'First) - & " (should be both 1)"); - NT.Info (Report, - "End: " - & Natural'Image (Token_End (1)) & " /= " - & Natural'Image (Index (Magic_String, B_Set)) - & " (should be both 2)"); - end if; - if not Tests (2) then - NT.Info - (Report, - "Start: " & Positive'Image (Token_Start (2)) & " (should be 3)"); - NT.Info - (Report, - "End: " & Natural'Image (Token_End (2)) & " (should be 3)"); - end if; - if not Tests (3) then - NT.Info - (Report, - "Start: " - & Positive'Image (Token_Start (3)) & " /= " - & Positive'Image (To_String (Magic_String)'First) - & " (should be 1)"); - NT.Info - (Report, - "End: " - & Natural'Image (Token_End (3)) & " (should be 0)"); - end if; - - -- Translate - Incantation := Translate (Magic_String, Code_Map); - Tests (1) := Incantation = To_Chunked_String ("wxrwywzwxrw"); - NT.Item (Report, "Function Translate", - NT.To_Result (Tests (1))); - if not Tests (1) then - NT.Info (Report, - '"' & To_String (Incantation) - & """ /= ""wxrwywzwxrw"""); - end if; - Translate (Incantation, Reverse_Code_Map); - Tests (1) := Incantation = Translate (Magic_String, Non_Existent_Map); - NT.Item - (Report, "Procedure Translate", NT.To_Result (Tests (1))); - if not Tests (1) then - NT.Info (Report, - '"' & To_String (Incantation) & """ /= """ - & To_String (Translate (Magic_String, - Non_Existent_Map)) - & """ (should be """ - & To_String (Magic_String) & """)"); - end if; - - -- Trim - declare - XYZ_Set : constant Maps.Character_Set := Maps.To_Set ("xyz"); - PQR_Set : constant Maps.Character_Set := Maps.To_Set ("pqr"); - Pad : constant Chunked_String := To_Chunked_String ("Pad"); - The_New_Ada : constant Chunked_String := To_Chunked_String ("Ada9X"); - Space_Array : constant array (1 .. 4) of Chunked_String - := (To_Chunked_String (" Pad "), - To_Chunked_String ("Pad "), - To_Chunked_String (" Pad"), - Pad); - String_Array : constant array (1 .. 5) of Chunked_String - := (To_Chunked_String ("xyzxAda9Xpqr"), - To_Chunked_String ("Ada9Xqqrp"), - To_Chunked_String ("zxyxAda9Xqpqr"), - To_Chunked_String ("xxxyAda9X"), - The_New_Ada); - begin - for I in 1 .. 4 loop - Tests (I) := Trim (Space_Array (I), Ada.Strings.Both) = Pad; - end loop; - NT.Item - (Report, "Trim spaces", - NT.To_Result (Tests (1) and Tests (2) - and Tests (3) and Tests (4))); - for I in 1 .. 4 loop - if not Tests (I) then - NT.Info - (Report, - "Part" & Positive'Image (I) & ": Trim (""" - & To_String (Space_Array (I)) & """, Both) -> """ - & To_String (Trim (Space_Array (I), Ada.Strings.Both)) - & """ (shoud be """ & To_String (Pad) & '"'); - end if; - end loop; - - for I in 1 .. 5 loop - Tests (I) := Trim (String_Array (I), - Left => XYZ_Set, - Right => PQR_Set) - = The_New_Ada; - end loop; - NT.Item - (Report, "Trim sets of characters", - NT.To_Result (Tests (1) and Tests (2) and Tests (3) - and Tests (4) and Tests (5))); - for I in 1 .. 5 loop - if not Tests (I) then - NT.Info - (Report, - "Part" & Positive'Image (I) & ": Trim (""" - & To_String (String_Array (I)) - & """, XYZ_Set, PQR_Set) -> """ - & To_String (Trim (String_Array (I), XYZ_Set, PQR_Set)) - & """ (shoud be """ & To_String (The_New_Ada) & '"'); - end if; - end loop; - end; - - -- Delete - Tests (1) := Delete (Source => Delete (Magic_String, - 8, Length (Magic_String)), - From => To_String (Magic_String)'First, - Through => 4) - = Cad_String; - NT.Item (Report, "Function Delete", - NT.To_Result (Tests (1))); - if not Tests (1) then - NT.Info - (Report, - '"' & To_String (Delete (Delete (Magic_String, - 8, Length (Magic_String)), - To_String (Magic_String)'First, 4)) - & """ /= """ & To_String (Cad_String) & '"'); - end if; - - -- Constructors "*" - declare - SOS : Chunked_String; - Dot : constant Chunked_String := To_Chunked_String ("Dot_"); - Dash : constant String := "Dash_"; - Distress : constant Chunked_String - := To_Chunked_String ("Dot_Dot_Dot_") - & To_Chunked_String ("Dash_Dash_Dash_") - & To_Chunked_String ("Dot_Dot_Dot"); - Repeat : constant Natural := 3; - Separator : constant Character := '_'; - Separator_Set : constant Maps.Character_Set - := Maps.To_Set (Separator); - begin - SOS := Repeat * Dot; - SOS := SOS & Repeat * Dash & Repeat * Dot; - if Trim (SOS, Maps.Null_Set, Separator_Set) /= Distress then - NT.Item (Report, "Function ""*""", NT.Fail); - NT.Info - (Report, - '"' & To_String (Trim (SOS, Maps.Null_Set, Separator_Set)) - & """ /= """ & To_String (Distress) & '"'); - else - NT.Item (Report, "Function ""*""", - NT.Success); - end if; - end; - exception - when Error : others => - NT.Report_Exception (Report, "Preparation", Error); - end; - - NT.End_Section (Report); - -end Natools.Chunked_Strings.Tests.CXA4011; DELETED natools-chunked_strings-tests-cxa4011.ads Index: natools-chunked_strings-tests-cxa4011.ads ================================================================== --- natools-chunked_strings-tests-cxa4011.ads +++ natools-chunked_strings-tests-cxa4011.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests.CXA4011 is the transcription to -- --- Chunked_String of ACATS test CXA4011 for Unbounded_String. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic procedure Natools.Chunked_Strings.Tests.CXA4011 - (Report : in out Natools.Tests.Reporter'Class); -pragma Preelaborate (CXA4011); DELETED natools-chunked_strings-tests-cxa4030.adb Index: natools-chunked_strings-tests-cxa4030.adb ================================================================== --- natools-chunked_strings-tests-cxa4030.adb +++ natools-chunked_strings-tests-cxa4030.adb @@ -1,549 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; -with Ada.Characters.Latin_1; -with Ada.Exceptions; -with Ada.Strings; use Ada.Strings; - -procedure Natools.Chunked_Strings.Tests.CXA4030 - (Report : in out Natools.Tests.Reporter'Class) -is - package NT renames Natools.Tests; -begin - NT.Section (Report, "Port of ACATS CXA4030"); - - declare - package L1 renames Ada.Characters.Latin_1; - - New_Character_String : Chunked_String - := To_Chunked_String (L1.LC_A_Grave & L1.LC_A_Ring - & L1.LC_AE_Diphthong & L1.LC_C_Cedilla - & L1.LC_E_Acute & L1.LC_I_Circumflex - & L1.LC_Icelandic_Eth & L1.LC_N_Tilde - & L1.LC_O_Oblique_Stroke & L1.LC_Icelandic_Thorn); - - TC_New_Character_String : constant Chunked_String - := To_Chunked_String (L1.UC_A_Grave & L1.UC_A_Ring - & L1.UC_AE_Diphthong & L1.UC_C_Cedilla - & L1.UC_E_Acute & L1.UC_I_Circumflex - & L1.UC_Icelandic_Eth & L1.UC_N_Tilde - & L1.UC_O_Oblique_Stroke & L1.UC_Icelandic_Thorn); - Map_To_Lower_Case_Ptr : constant Maps.Character_Mapping_Function - := Ada.Characters.Handling.To_Lower'Access; - Map_To_Upper_Case_Ptr : constant Maps.Character_Mapping_Function - := Ada.Characters.Handling.To_Upper'Access; - begin - NT.Section (Report, "Function Index, Forward direction"); - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Test (Report, Name, - Index (Source => To_Chunked_String - ("The library package Strings.Unbounded"), - Pattern => "unb", - Going => Ada.Strings.Forward, - Mapping => Map_To_Lower_Case_Ptr), - 29); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower"; - begin - Test (Report, Name, - Index (To_Chunked_String - ("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"), - "ain", - Mapping => Map_To_Lower_Case_Ptr), - 6); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to lower"; - begin - Test (Report, Name, - Index (To_Chunked_String ("maximum number"), - "um", - Ada.Strings.Forward, - Ada.Characters.Handling.To_Lower'Access), - 6); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to upper"; - begin - Test (Report, Name, - Index (To_Chunked_String ("CoMpLeTeLy MiXeD CaSe StRiNg"), - "MIXED CASE STRING", - Ada.Strings.Forward, - Map_To_Upper_Case_Ptr), - 12); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower (no match)"; - begin - Test (Report, Name, - Index (To_Chunked_String - ("STRING WITH NO MATCHING PATTERNS"), - "WITH", - Mapping => Map_To_Lower_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to upper"; - begin - Test (Report, Name, - Index (To_Chunked_String ("THIS STRING IS IN UPPER CASE"), - "IS", - Ada.Strings.Forward, - Ada.Characters.Handling.To_Upper'Access), - 3); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Null string"; - begin - Test (Report, Name, - Index (Null_Chunked_String, - "is", - Mapping => Map_To_Lower_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower"; - begin - Test (Report, Name, - Index (To_Chunked_String ("AAABBBaaabbb"), - "aabb", - Mapping => Ada.Characters.Handling.To_Lower'Access), - 2); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Function Index, Backward direction"); - - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Test (Report, Name, - Index (To_Chunked_String ("Case of a Mixed Case String"), - "case", - Ada.Strings.Backward, - Map_To_Lower_Case_Ptr), - 17); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to upper"; - begin - Test (Report, Name, - Index (To_Chunked_String ("Case of a Mixed Case String"), - "CASE", - Ada.Strings.Backward, - Mapping => Map_To_Upper_Case_Ptr), - 17); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower"; - begin - Test (Report, Name, - Index (To_Chunked_String ("rain, Rain, and more RAIN"), - "rain", - Ada.Strings.Backward, - Ada.Characters.Handling.To_Lower'Access), - 22); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to upper"; - begin - Test (Report, Name, - Index (To_Chunked_String ("RIGHT place, right time"), - "RIGHT", - Going => Ada.Strings.Backward, - Mapping => Ada.Characters.Handling.To_Upper'Access), - 14); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower (no match)"; - begin - Test (Report, Name, - Index (To_Chunked_String ("WOULD MATCH BUT FOR THE CASE"), - "WOULD MATCH BUT FOR THE CASE", - Going => Ada.Strings.Backward, - Mapping => Map_To_Lower_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - declare - Null_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural - := Index (To_Chunked_String ("A Valid Chunked String"), - Null_String, - Going => Ada.Strings.Forward, - Mapping => Ada.Characters.Handling.To_Lower'Access); - NT.Item (Report, "Pattern_Error raised in Index", NT.Fail); - NT.Info (Report, "No exception has been raised."); - NT.Info (Report, "Return value: " & Natural'Image (TC_Natural)); - exception - when Pattern_Error => - NT.Item (Report, "Pattern_Error raised in Index", NT.Success); - when Error : others => - NT.Item (Report, "Pattern_Error raised in Index", NT.Fail); - NT.Info (Report, "Wrong exception " - & Ada.Exceptions.Exception_Name (Error) - & "has been raised."); - end; - - - NT.Section (Report, "Function Count with mapping function"); - - declare - Name : constant String := "Upper case mapped to lower"; - begin - Test (Report, Name, - Count (Source => To_Chunked_String ("ABABABA"), - Pattern => "aba", - Mapping => Map_To_Lower_Case_Ptr), - 2); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower (no match)"; - begin - Test (Report, Name, - Count (To_Chunked_String ("ABABABA"), - "ABA", - Mapping => Map_To_Lower_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Test (Report, Name, - Count (To_Chunked_String ("This IS a MISmatched issue"), - "is", - Ada.Characters.Handling.To_Lower'Access), - 4); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to upper"; - begin - Test (Report, Name, - Count (To_Chunked_String ("ABABABA"), - "ABA", - Map_To_Upper_Case_Ptr), - 2); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to upper (no match)"; - begin - Test (Report, Name, - Count (To_Chunked_String ("This IS a MISmatched issue"), - "is", - Mapping => Map_To_Upper_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Test (Report, Name, - Count (To_Chunked_String - ("She sells sea shells by the sea shore"), - "s", - Ada.Characters.Handling.To_Lower'Access), - 8); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty string"; - begin - Test (Report, Name, - Count (Null_Chunked_String, - "match", - Map_To_Upper_Case_Ptr), - 0); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - declare - Null_Pattern_String : constant String := ""; - TC_Natural : Natural := 1000; - begin - TC_Natural := Count (To_Chunked_String ("A Valid String"), - Null_Pattern_String, - Map_To_Lower_Case_Ptr); - NT.Item (Report, "Pattern_Error raised in Count", NT.Fail); - NT.Info (Report, "No exception has been raised."); - NT.Info (Report, "Return value: " & Natural'Image (TC_Natural)); - exception - when Pattern_Error => - NT.Item (Report, "Pattern_Error raised in Count", NT.Success); - when Error : others => - NT.Item (Report, "Pattern_Error raised in Count", NT.Fail); - NT.Info (Report, "Wrong exception " - & Ada.Exceptions.Exception_Name (Error) - & "has been raised."); - end; - - - NT.Section (Report, "Function Translate"); - - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Test (Report, Name, - Translate (Source => To_Chunked_String - ("A Sample Mixed Case String"), - Mapping => Map_To_Lower_Case_Ptr), - "a sample mixed case string"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to lower"; - begin - Test (Report, Name, - Translate (To_Chunked_String ("ALL LOWER CASE"), - Ada.Characters.Handling.To_Lower'Access), - "all lower case"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to lower"; - begin - Test (Report, Name, - Translate (To_Chunked_String ("end with lower case"), - Map_To_Lower_Case_Ptr), - "end with lower case"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty string"; - begin - Test (Report, Name, - Translate (Null_Chunked_String, - Ada.Characters.Handling.To_Lower'Access), - Null_Chunked_String); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to upper"; - begin - Test (Report, Name, - Translate (To_Chunked_String ("start with lower case"), - Map_To_Upper_Case_Ptr), - "START WITH LOWER CASE"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Upper case mapped to upper"; - begin - Test (Report, Name, - Translate (To_Chunked_String ("ALL UPPER CASE STRING"), - Ada.Characters.Handling.To_Upper'Access), - "ALL UPPER CASE STRING"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to upper"; - begin - Test (Report, Name, - Translate (To_Chunked_String - ("LoTs Of MiXeD CaSe ChArAcTeRs"), - Map_To_Upper_Case_Ptr), - "LOTS OF MIXED CASE CHARACTERS"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Diacritics"; - begin - Test (Report, Name, - Translate (New_Character_String, - Ada.Characters.Handling.To_Upper'Access), - TC_New_Character_String); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Procedure Translate"); - - declare - use Ada.Characters.Handling; - - Str_1 : Chunked_String - := To_Chunked_String ("AN ALL UPPER CASE STRING"); - Str_2 : Chunked_String - := To_Chunked_String ("A Mixed Case String"); - Str_3 : Chunked_String - := To_Chunked_String ("a string with lower case letters"); - TC_Str_1 : constant Chunked_String := Str_1; - TC_Str_3 : constant Chunked_String := Str_3; - begin - declare - Name : constant String := "Upper case mapped to lower"; - begin - Translate (Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); - Test (Report, Name, Str_1, - To_Chunked_String ("an all upper case string")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped back to upper"; - begin - Translate (Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); - Test (Report, Name, Str_1, TC_Str_1); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Mixed case mapped to lower"; - begin - Translate (Str_2, Mapping => Map_To_Lower_Case_Ptr); - Test (Report, Name, Str_2, - To_Chunked_String ("a mixed case string")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to upper"; - begin - Translate (Str_2, Mapping => To_Upper'Access); - Test (Report, Name, Str_2, - To_Chunked_String ("A MIXED CASE STRING")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to lower"; - begin - Translate (Str_3, To_Lower'Access); - Test (Report, Name, Str_3, TC_Str_3); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Lower case mapped to upper"; - begin - Translate (Str_3, To_Upper'Access); - Test (Report, Name, Str_3, - To_Chunked_String ("A STRING WITH LOWER CASE LETTERS")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Diacritics"; - begin - Translate (New_Character_String, Map_To_Upper_Case_Ptr); - Test (Report, Name, New_Character_String, TC_New_Character_String); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - end; - - NT.End_Section (Report); - exception - when Error : others => - NT.Item (Report, "Preparation", NT.Error); - NT.Info (Report, "Exception: " - & Ada.Exceptions.Exception_Name (Error)); - NT.Info (Report, Ada.Exceptions.Exception_Message (Error)); - end; - - NT.End_Section (Report); - -end Natools.Chunked_Strings.Tests.CXA4030; DELETED natools-chunked_strings-tests-cxa4030.ads Index: natools-chunked_strings-tests-cxa4030.ads ================================================================== --- natools-chunked_strings-tests-cxa4030.ads +++ natools-chunked_strings-tests-cxa4030.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests.CXA4030 is the transcription to -- --- Chunked_String of ACATS test CXA4030 for Unbounded_String. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic procedure Natools.Chunked_Strings.Tests.CXA4030 - (Report : in out Natools.Tests.Reporter'Class); -pragma Preelaborate (CXA4030); DELETED natools-chunked_strings-tests-cxa4031.adb Index: natools-chunked_strings-tests-cxa4031.adb ================================================================== --- natools-chunked_strings-tests-cxa4031.adb +++ natools-chunked_strings-tests-cxa4031.adb @@ -1,440 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; - -procedure Natools.Chunked_Strings.Tests.CXA4031 - (Report : in out Natools.Tests.Reporter'Class) -is - package NT renames Natools.Tests; -begin - NT.Section (Report, "Port of ACATS CXA4031"); - - declare - subtype LC_Characters is Character range 'a' .. 'z'; - - Null_String : constant String := ""; - TC_String : constant String := "A Standard String"; - - TC_Chunked_String, - TC_New_Chunked_String : Chunked_String := Null_Chunked_String; - begin - NT.Section (Report, "Function To_Chunked_String with Length parameter"); - - declare - Name : constant String := "Length = 10"; - Result : Natural; - begin - Result := Length (To_Chunked_String (Length => 10)); - if Result = 10 then - NT.Item (Report, Name, NT.Success); - else - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Found length" & Natural'Image (Result)); - end if; - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Singleton"; - Result : Natural; - begin - Result := Length (To_Chunked_String (1)); - if Result = 1 then - NT.Item (Report, Name, NT.Success); - else - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Found length" & Natural'Image (Result)); - end if; - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty string"; - Result : Natural; - begin - Result := Length (To_Chunked_String (0)); - if Result = 0 then - NT.Item (Report, Name, NT.Success); - else - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Found length" & Natural'Image (Result)); - end if; - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Concatenation of the above"; - Result : Natural; - begin - Result := Length (To_Chunked_String (Length => 10) - & To_Chunked_String (1) - & To_Chunked_String (0)); - if Result = 10 + 1 + 0 then - NT.Item (Report, Name, NT.Success); - else - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Found length" & Natural'Image (Result)); - end if; - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Append (Chunked, Chunked)"); - - declare - Name : constant String := "Non-empty and non-empty"; - begin - TC_Chunked_String := To_Chunked_String ("Sample string of length L"); - TC_New_Chunked_String := To_Chunked_String (" and then some"); - Append (TC_Chunked_String, TC_New_Chunked_String); - Test (Report, Name, TC_Chunked_String, - "Sample string of length L and then some"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Non-empty and empty"; - begin - TC_Chunked_String := To_Chunked_String ("Sample string of length L"); - TC_New_Chunked_String := Null_Chunked_String; - Test (Report, Name, TC_Chunked_String, "Sample string of length L"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty and non-empty"; - begin - TC_Chunked_String := Null_Chunked_String; - Append (TC_Chunked_String, - To_Chunked_String ("New Chunked String")); - Test (Report, Name, TC_Chunked_String, "New Chunked String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Procedure Append (Chunked, String)"); - - declare - Name : constant String := "Non-empty and non-empty"; - begin - TC_Chunked_String := To_Chunked_String ("A Chunked String and "); - Append (Source => TC_Chunked_String, New_Item => TC_String); - Test (Report, Name, TC_Chunked_String, - "A Chunked String and A Standard String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Non-empty and empty"; - begin - TC_Chunked_String := To_Chunked_String ("A Chunked String"); - Append (TC_Chunked_String, New_Item => Null_String); - Test (Report, Name, TC_Chunked_String, "A Chunked String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty and non-empty"; - begin - TC_Chunked_String := Null_Chunked_String; - Append (TC_Chunked_String, TC_String); - Test (Report, Name, TC_Chunked_String, "A Standard String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Procedure Append (Chunked, Character)"); - - declare - Name : constant String := "Non-empty initial string"; - begin - TC_Chunked_String := To_Chunked_String ("Lower Case = "); - for I in LC_Characters'Range loop - Append (Source => TC_Chunked_String, - New_Item => I); - end loop; - Test (Report, Name, TC_Chunked_String, - "Lower Case = abcdefghijklmnopqrstuvwxyz"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty initial string"; - begin - TC_Chunked_String := Null_Chunked_String; - Append (TC_Chunked_String, New_Item => 'a'); - Test (Report, Name, TC_Chunked_String, "a"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Function ""="""); - TC_Chunked_String := To_Chunked_String (TC_String); - - declare - Name : constant String := "Chunked_String and String"; - begin - NT.Item (Report, Name, NT.To_Result (TC_Chunked_String = TC_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "String and Chunked_String"; - begin - NT.Item (Report, Name, - NT.To_Result ("A Standard String" = TC_Chunked_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty chunked string and empty string"; - begin - NT.Item (Report, Name, NT.To_Result (Null_Chunked_String = "")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "With inline conversion"; - begin - NT.Item (Report, Name, - NT.To_Result ("Test String" = To_Chunked_String ("Test String"))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Function ""<"""); - - declare - Name : constant String := "Differing by a trailing space"; - begin - NT.Item (Report, Name, - NT.To_Result ("Extra Space" < To_Chunked_String ("Extra Space "))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by the last letter"; - begin - NT.Item (Report, Name, - NT.To_Result (To_Chunked_String ("tess") < "test")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by the first letter"; - begin - NT.Item (Report, Name, - NT.To_Result (To_Chunked_String ("best") < "test")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty strings"; - begin - NT.Item (Report, Name, - NT.To_Result (not (Null_Chunked_String < Null_String))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Equal with leading blank"; - begin - NT.Item (Report, Name, - NT.To_Result (not (" leading blank" - < To_Chunked_String (" leading blank")))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Equal with ending blank"; - begin - NT.Item (Report, Name, - NT.To_Result (not ("ending blank " - < To_Chunked_String ("ending blank ")))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Function ""<="""); - TC_Chunked_String := To_Chunked_String ("Sample string"); - - declare - Name : constant String := "Prefix"; - begin - NT.Item (Report, Name, - NT.To_Result (not (TC_Chunked_String <= "Sample strin"))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by case"; - begin - NT.Item (Report, Name, - NT.To_Result (not ("sample string" <= TC_Chunked_String))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty strings"; - begin - NT.Item (Report, Name, NT.To_Result (Null_Chunked_String <= "")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Equal strings"; - begin - NT.Item (Report, Name, - NT.To_Result ("Sample string" <= TC_Chunked_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Function "">"""); - TC_Chunked_String := To_Chunked_String ("A MUCH LONGER STRING"); - - declare - Name : constant String := "Differing by case"; - begin - NT.Item (Report, Name, - NT.To_Result ("A much longer string" > TC_Chunked_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Prefix"; - begin - NT.Item (Report, Name, - NT.To_Result (To_Chunked_String (TC_String) > "A Standard Strin")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by case"; - begin - NT.Item (Report, Name, - NT.To_Result ("abcdefgh" > To_Chunked_String ("ABCDEFGH"))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty strings"; - begin - NT.Item (Report, Name, - NT.To_Result (not (Null_Chunked_String > Null_String))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - - NT.Section (Report, "Function "">="""); - TC_Chunked_String := To_Chunked_String (TC_String); - - declare - Name : constant String := "Equal strings"; - begin - NT.Item (Report, Name, NT.To_Result (TC_Chunked_String >= TC_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Empty strings"; - begin - NT.Item (Report, Name, - NT.To_Result (Null_String >= Null_Chunked_String)); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by the last letter"; - begin - NT.Item (Report, Name, - NT.To_Result ("test" >= To_Chunked_String ("tess"))); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - declare - Name : constant String := "Differing by case"; - begin - NT.Item (Report, Name, - NT.To_Result (To_Chunked_String ("Programming") >= "PROGRAMMING")); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - exception - when Error : others => - NT.Item (Report, "Preparation", NT.Error); - NT.Info (Report, "Exception: " - & Ada.Exceptions.Exception_Name (Error)); - NT.Info (Report, Ada.Exceptions.Exception_Message (Error)); - end; - - NT.End_Section (Report); - -end Natools.Chunked_Strings.Tests.CXA4031; DELETED natools-chunked_strings-tests-cxa4031.ads Index: natools-chunked_strings-tests-cxa4031.ads ================================================================== --- natools-chunked_strings-tests-cxa4031.ads +++ natools-chunked_strings-tests-cxa4031.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests.CXA4031 is the transcription to -- --- Chunked_String of ACATS test CXA4031 for Unbounded_String. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic procedure Natools.Chunked_Strings.Tests.CXA4031 - (Report : in out Natools.Tests.Reporter'Class); -pragma Preelaborate (CXA4031); DELETED natools-chunked_strings-tests-cxa4032.adb Index: natools-chunked_strings-tests-cxa4032.adb ================================================================== --- natools-chunked_strings-tests-cxa4032.adb +++ natools-chunked_strings-tests-cxa4032.adb @@ -1,536 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Strings.Maps.Constants; - -procedure Natools.Chunked_Strings.Tests.CXA4032 - (Report : in out Natools.Tests.Reporter'Class) -is - package NT renames Natools.Tests; -begin - NT.Section (Report, "Port of ACATS CXA4032"); - - declare - TC_Null_String : constant String := ""; - TC_String_5 : constant String (1 .. 5) := "ABCDE"; - TC_Chunked_String : Chunked_String := To_Chunked_String ("Test String"); - begin - NT.Section (Report, "Procedure Replace_Slice"); - declare - Name : constant String - := "Index_Error raised when Low > Source'Last+1"; - begin - Replace_Slice (Source => TC_Chunked_String, - Low => Length (TC_Chunked_String) + 2, - High => Length (TC_Chunked_String), - By => TC_String_5); - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "No exception has been raised."); - NT.Info (Report, - "Final value: """ & To_String (TC_Chunked_String) & '"'); - exception - when Ada.Strings.Index_Error => - NT.Item (Report, Name, NT.Success); - when Error : others => - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Wrong exception " - & Ada.Exceptions.Exception_Name (Error) - & " raised instead"); - end; - - - declare - Name : constant String := "1-character slice replacement"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Replace_Slice (TC_Chunked_String, 5, 5, TC_String_5); - Test (Report, Name, TC_Chunked_String, "TestABCDEString"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Prefix replacement"; - begin - Replace_Slice (TC_Chunked_String, 1, 4, TC_String_5); - Test (Report, Name, TC_Chunked_String, "ABCDEABCDEString"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Suffix replacement by empty"; - begin - Replace_Slice (TC_Chunked_String, - 11, - Length (TC_Chunked_String), - TC_Null_String); - Test (Report, Name, TC_Chunked_String, "ABCDEABCDE"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Slice insertion in the middle"; - begin - Replace_Slice (TC_Chunked_String, Low => 4, High => 1, By => "xxx"); - Test (Report, Name, TC_Chunked_String, "ABCxxxDEABCDE"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Slice insertion at the beginning"; - begin - Replace_Slice (TC_Chunked_String, Low => 1, High => 0, By => "yyy"); - Test (Report, Name, TC_Chunked_String, "yyyABCxxxDEABCDE"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Slice insertion at the end"; - begin - Replace_Slice (TC_Chunked_String, - Length (TC_Chunked_String) + 1, - Length (TC_Chunked_String), - By => "zzz"); - Test (Report, Name, TC_Chunked_String, "yyyABCxxxDEABCDEzzz"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Insert"); - TC_Chunked_String := To_Chunked_String ("Test String"); - - declare - Name : constant String := "Index_Error raised on incorrect Before"; - begin - Insert (Source => TC_Chunked_String, - Before => Length (TC_Chunked_String) + 2, - New_Item => TC_String_5); - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "No exception has been raised."); - NT.Info (Report, - "Final value: """ & To_String (TC_Chunked_String) & '"'); - exception - when Ada.Strings.Index_Error => - NT.Item (Report, Name, NT.Success); - when Error : others => - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Wrong exception " - & Ada.Exceptions.Exception_Name (Error) - & " raised instead"); - end; - - - declare - Name : constant String := "Prefix insertion"; - begin - Insert (TC_Chunked_String, 1, "**"); - Test (Report, Name, TC_Chunked_String, "**Test String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Suffix insertion"; - begin - Insert (TC_Chunked_String, Length (TC_Chunked_String) + 1, "**"); - Test (Report, Name, TC_Chunked_String, "**Test String**"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Insertion in the middle"; - begin - Insert (TC_Chunked_String, 8, "---"); - Test (Report, Name, TC_Chunked_String, "**Test ---String**"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty insertion"; - begin - Insert (TC_Chunked_String, 3, TC_Null_String); - Test (Report, Name, TC_Chunked_String, "**Test ---String**"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Overwrite"); - - declare - Name : constant String := "Index_Error raised on incorrect Position"; - begin - Overwrite (Source => TC_Chunked_String, - Position => Length (TC_Chunked_String) + 2, - New_Item => TC_String_5); - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "No exception has been raised."); - NT.Info (Report, - "Final value: """ & To_String (TC_Chunked_String) & '"'); - exception - when Ada.Strings.Index_Error => - NT.Item (Report, Name, NT.Success); - when Error : others => - NT.Item (Report, Name, NT.Fail); - NT.Info (Report, "Wrong exception " - & Ada.Exceptions.Exception_Name (Error) - & " raised instead"); - end; - - - declare - Name : constant String := "Normal overwrite"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Overwrite (Source => TC_Chunked_String, - Position => 1, - New_Item => "XXXX"); - Test (Report, Name, TC_Chunked_String, "XXXX String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Overwrite after the end"; - begin - Overwrite (TC_Chunked_String, Length (TC_Chunked_String) + 1, "**"); - Test (Report, Name, TC_Chunked_String, "XXXX String**"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty overwrite"; - begin - Overwrite (TC_Chunked_String, 3, TC_Null_String); - Test (Report, Name, TC_Chunked_String, "XXXX String**"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Complete overwrite"; - begin - Overwrite (TC_Chunked_String, 1, "abcdefghijklmn"); - Test (Report, Name, TC_Chunked_String, "abcdefghijklmn"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Delete"); - - - declare - Name : constant String := "Empty deletion at the end"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Delete (Source => TC_Chunked_String, - From => Length (TC_Chunked_String), - Through => Length (TC_Chunked_String) - 1); - Test (Report, Name, TC_Chunked_String, "Test String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty deletion at the beginning"; - begin - Delete (TC_Chunked_String, 1, 0); - Test (Report, Name, TC_Chunked_String, "Test String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Prefix deletion"; - begin - Delete (TC_Chunked_String, 1, 5); - Test (Report, Name, TC_Chunked_String, "String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "1-character range deletion"; - begin - Delete (TC_Chunked_String, 3, 3); - Test (Report, Name, TC_Chunked_String, "Sting"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Trim"); - - - declare - Name : constant String := "Nothing to trim"; - begin - TC_Chunked_String := To_Chunked_String ("No Spaces"); - Trim (Source => TC_Chunked_String, Side => Ada.Strings.Both); - Test (Report, Name, TC_Chunked_String, "No Spaces"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Trim left but not right"; - begin - TC_Chunked_String := To_Chunked_String (" Leading Spaces "); - Trim (TC_Chunked_String, Ada.Strings.Left); - Test (Report, Name, TC_Chunked_String, "Leading Spaces "); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Trim right but not left"; - begin - TC_Chunked_String := To_Chunked_String (" Ending Spaces "); - Trim (TC_Chunked_String, Ada.Strings.Right); - Test (Report, Name, TC_Chunked_String, " Ending Spaces"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Trim on both sides"; - begin - TC_Chunked_String - := To_Chunked_String (" Spaces on both ends "); - Trim (TC_Chunked_String, Ada.Strings.Both); - Test (Report, Name, TC_Chunked_String, "Spaces on both ends"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Trim (with Character Set parameter)"); - - declare - Name : constant String := "Normal trim"; - begin - TC_Chunked_String := To_Chunked_String ("lowerCASEletters"); - Trim (Source => TC_Chunked_String, - Left => Ada.Strings.Maps.Constants.Lower_Set, - Right => Ada.Strings.Maps.Constants.Lower_Set); - Test (Report, Name, TC_Chunked_String, "CASE"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Nothing to trim"; - begin - TC_Chunked_String := To_Chunked_String ("lowerCASEletters"); - Trim (TC_Chunked_String, - Ada.Strings.Maps.Constants.Upper_Set, - Ada.Strings.Maps.Constants.Upper_Set); - Test (Report, Name, TC_Chunked_String, "lowerCASEletters"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Normal trim"; - begin - TC_Chunked_String := To_Chunked_String ("012abcdefghGFEDCBA789ab"); - Trim (TC_Chunked_String, - Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set, - Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set); - Test (Report, Name, TC_Chunked_String, "ghG"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Head"); - - declare - Name : constant String := "Empty head"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Head (Source => TC_Chunked_String, - Count => 0, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, Null_Chunked_String); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Normal Head"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Head (Source => TC_Chunked_String, - Count => 4, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "Test"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "No-op Head"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Head (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String), - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "Test String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Head with padding"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Head (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String) + 4, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "Test String****"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty string with padding"; - begin - TC_Chunked_String := Null_Chunked_String; - Head (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String) + 3, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "***"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - - NT.Section (Report, "Procedure Tail"); - - declare - Name : constant String := "Empty tail"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Tail (Source => TC_Chunked_String, - Count => 0, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, Null_Chunked_String); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Normal tail"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Tail (Source => TC_Chunked_String, - Count => 6, - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "No-op tail"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Tail (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String), - Pad => '*'); - Test (Report, Name, TC_Chunked_String, "Test String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Tail with padding"; - begin - TC_Chunked_String := To_Chunked_String ("Test String"); - Tail (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String) + 5, - Pad => 'x'); - Test (Report, Name, TC_Chunked_String, "xxxxxTest String"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - - declare - Name : constant String := "Empty string with padding"; - begin - TC_Chunked_String := Null_Chunked_String; - Tail (Source => TC_Chunked_String, - Count => Length (TC_Chunked_String) + 3, - Pad => 'X'); - Test (Report, Name, TC_Chunked_String, "XXX"); - exception - when Error : others => NT.Report_Exception (Report, Name, Error); - end; - - NT.End_Section (Report); - exception - when Error : others => - NT.Report_Exception (Report, "Preparation", Error); - end; - - NT.End_Section (Report); - -end Natools.Chunked_Strings.Tests.CXA4032; DELETED natools-chunked_strings-tests-cxa4032.ads Index: natools-chunked_strings-tests-cxa4032.ads ================================================================== --- natools-chunked_strings-tests-cxa4032.ads +++ natools-chunked_strings-tests-cxa4032.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests.CXA4032 is the transcription to -- --- Chunked_String of ACATS test CXA4032 for Unbounded_String. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic procedure Natools.Chunked_Strings.Tests.CXA4032 - (Report : in out Natools.Tests.Reporter'Class); -pragma Preelaborate (CXA4032); DELETED natools-chunked_strings-tests.adb Index: natools-chunked_strings-tests.adb ================================================================== --- natools-chunked_strings-tests.adb +++ natools-chunked_strings-tests.adb @@ -1,195 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Natools.Chunked_Strings.Tests.CXA4010; -with Natools.Chunked_Strings.Tests.CXA4011; -with Natools.Chunked_Strings.Tests.CXA4030; -with Natools.Chunked_Strings.Tests.CXA4031; -with Natools.Chunked_Strings.Tests.CXA4032; - -package body Natools.Chunked_Strings.Tests is - package NT renames Natools.Tests; - - procedure All_Blackbox_Tests (Report : in out Natools.Tests.Reporter'Class) - is - procedure Test_CXA4010 is new CXA4010; - procedure Test_CXA4011 is new CXA4011; - procedure Test_CXA4030 is new CXA4030; - procedure Test_CXA4031 is new CXA4031; - procedure Test_CXA4032 is new CXA4032; - begin - NT.Section (Report, "Blackbox tests of Chunked_Strings"); - Test_CXA4010 (Report); - Test_CXA4011 (Report); - Test_CXA4030 (Report); - Test_CXA4031 (Report); - Test_CXA4032 (Report); - NT.End_Section (Report); - end All_Blackbox_Tests; - - - procedure All_Tests (Report : in out Natools.Tests.Reporter'Class) is - begin - NT.Section (Report, "All tests of Chunked_Strings"); - All_Blackbox_Tests (Report); - NT.End_Section (Report); - end All_Tests; - - - - procedure Dump (Report : in out Natools.Tests.Reporter'Class; - Dumped : in Chunked_String) - is - package Maps renames Ada.Strings.Maps; - use type Maps.Character_Set; - - procedure Print_Chunk (Index : Positive; Chunk : String_Access); - procedure Print_Chunks (Data : Chunk_Array_Access); - procedure Print_Line (Raw : String); - - Printable : constant Maps.Character_Set - := Maps.To_Set (Maps.Character_Ranges'((Low => 'a', High => 'z'), - (Low => 'A', High => 'Z'), - (Low => '0', High => '9'))) - or Maps.To_Set (" -_"); - Non_Printable : constant Character := '.'; - - procedure Print_Chunk (Index : Positive; Chunk : String_Access) is - I : Natural; - begin - if Chunk = null then - NT.Info (Report, "Chunk" & Positive'Image (Index) & ": null"); - else - NT.Info (Report, "Chunk" & Positive'Image (Index) & ": " - & Natural'Image (Chunk.all'First) & " .." - & Natural'Image (Chunk.all'Last)); - I := Chunk.all'First; - while I <= Chunk.all'Last loop - Print_Line - (Chunk.all (I .. Positive'Min (Chunk.all'Last, I + 16))); - I := I + 16; - end loop; - end if; - end Print_Chunk; - - procedure Print_Chunks (Data : Chunk_Array_Access) is - begin - if Data = null then - NT.Info (Report, "Null data"); - end if; - if Data.all'Length = 0 then - NT.Info (Report, "Empty data"); - end if; - for C in Data.all'Range loop - Print_Chunk (C, Data.all (C)); - end loop; - end Print_Chunks; - - procedure Print_Line (Raw : String) is - Hex : constant String := "0123456789ABCDEF"; - Line : String (1 .. 4 * Raw'Length + 2) := (others => ' '); - begin - for I in Raw'Range loop - declare - Pos : constant Natural := Character'Pos (Raw (I)); - High : constant Natural := (Pos - 1) / 16; - Low : constant Natural := (Pos - 1) mod 16; - Hex_Base : constant Positive - := Line'First + 3 * (I - Raw'First); - Raw_Base : constant Positive - := Line'First + 3 * Raw'Length + 2 + (I - Raw'First); - begin - Line (Hex_Base) := Hex (Hex'First + High); - Line (Hex_Base + 1) := Hex (Hex'First + Low); - if Maps.Is_In (Raw (I), Printable) then - Line (Raw_Base) := Raw (I); - else - Line (Raw_Base) := Non_Printable; - end if; - end; - end loop; - NT.Info (Report, Line); - end Print_Line; - begin - NT.Info (Report, "Chunk_Size " & Positive'Image (Dumped.Chunk_Size) - & " (default" & Positive'Image (Default_Chunk_Size) - & ')'); - NT.Info (Report, "Allocation_Unit " - & Positive'Image (Dumped.Allocation_Unit) - & " (default" & Positive'Image (Default_Allocation_Unit) - & ')'); - NT.Info (Report, "Size " & Natural'Image (Dumped.Size)); - Print_Chunks (Dumped.Data); - end Dump; - - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Chunked_String; - Reference : in String) is - begin - if not Is_Valid (Computed) then - NT.Item (Report, Test_Name, NT.Error); - return; - end if; - if Computed = To_Chunked_String (Reference) then - NT.Item (Report, Test_Name, NT.Success); - else - NT.Item (Report, Test_Name, NT.Fail); - NT.Info (Report, "Computed """ & To_String (Computed) & '"'); - NT.Info (Report, "Reference """ & Reference & '"'); - end if; - end Test; - - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Chunked_String; - Reference : in Chunked_String) is - begin - if not Is_Valid (Computed) then - NT.Item (Report, Test_Name, NT.Error); - return; - end if; - if not Is_Valid (Reference) then - NT.Item (Report, Test_Name, NT.Error); - return; - end if; - if Computed = Reference then - NT.Item (Report, Test_Name, NT.Success); - else - NT.Item (Report, Test_Name, NT.Fail); - NT.Info (Report, "Computed """ & To_String (Computed) & '"'); - NT.Info (Report, "Reference """ & To_String (Reference) & '"'); - end if; - end Test; - - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Natural; - Reference : in Natural) is - begin - if Computed = Reference then - NT.Item (Report, Test_Name, NT.Success); - else - NT.Item (Report, Test_Name, NT.Fail); - NT.Info (Report, "Computed" & Natural'Image (Computed) - & ", expected" & Natural'Image (Reference)); - end if; - end Test; - -end Natools.Chunked_Strings.Tests; DELETED natools-chunked_strings-tests.ads Index: natools-chunked_strings-tests.ads ================================================================== --- natools-chunked_strings-tests.ads +++ natools-chunked_strings-tests.ads @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings.Tests is the test suite for Chunked_String. -- --- -- --- It currently contains only black-box tests (i.e. without any assumption -- --- on the internal implementaiton), taken from Unbounded_String tests in -- --- ACATS. -- --- -- --- It also provides private helper functions used in more specialized test -- --- packages. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -generic package Natools.Chunked_Strings.Tests is - pragma Preelaborate (Tests); - - procedure All_Blackbox_Tests (Report : in out Natools.Tests.Reporter'Class); - - procedure All_Tests (Report : in out Natools.Tests.Reporter'Class); - -private - - procedure Dump (Report : in out Natools.Tests.Reporter'Class; - Dumped : in Chunked_String); - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Chunked_String; - Reference : in String); - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Chunked_String; - Reference : in Chunked_String); - - procedure Test (Report : in out Natools.Tests.Reporter'Class; - Test_Name : in String; - Computed : in Natural; - Reference : in Natural); - -end Natools.Chunked_Strings.Tests; DELETED natools-chunked_strings.adb Index: natools-chunked_strings.adb ================================================================== --- natools-chunked_strings.adb +++ natools-chunked_strings.adb @@ -1,2235 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Strings; -with Ada.Strings.Fixed; -with Ada.Unchecked_Deallocation; - -package body Natools.Chunked_Strings is - - package Fixed renames Ada.Strings.Fixed; - - type Relation is (Equal, Greater, Lesser); - - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Allocated_Size (Source : in Chunked_String) return Natural; - pragma Inline (Allocated_Size); - -- Return the number of Characters that can currently fit in Source - - - function Chunks_For (Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive) - return Natural; - pragma Inline (Chunks_For); - -- Return the number of chunks to accommodate Size characters - - - generic - type Map_Type is private; - with function Count (Source : in String; - Pattern : in String; - Mapping : in Map_Type) - return Natural; - function Count_Gen (Source : in Chunked_String; - Pattern : in String; - Mapping : in Map_Type) - return Natural; - -- Count the number of non-overlapping occurrences of the pattern - - - function Compare - (Left : in Chunk_Array; - Left_Size : in Natural; - Right : in Chunk_Array; - Right_Size : in Natural) - return Relation; - function Compare - (Left : in Chunk_Array_Access; - Left_Size : in Natural; - Right : in Chunk_Array_Access; - Right_Size : in Natural) - return Relation; - function Compare - (Left : in Chunk_Array; - Left_Size : in Natural; - Right : in String) - return Relation; - function Compare - (Left : in Chunk_Array_Access; - Left_Size : in Natural; - Right : in String) - return Relation; - -- String comparisons - - - procedure Fill (Data : in out Chunk_Array; - From : in Positive; - Count : in Natural; - C : in Character; - Chunk_Size : in Positive); - -- Fill an area of the chunks with the given Character - - - procedure Free (Data : in out Chunk_Array_Access); - -- Free data associated to all chunks and to the chunk array - - - generic - type Map_Type is private; - with function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Ada.Strings.Direction; - Map : Map_Type) - return Natural; - function Index_Gen - (Source : Chunked_String; - Pattern : String; - From : Positive; - Going : Ada.Strings.Direction; - Map : Map_Type) - return Natural; - -- Search for a pattern in a source as described in the ARM - - - procedure Move (Target : in out Chunk_Array; - Target_Position : in Positive; - Source : in out Chunk_Array; - Source_Position : in Positive; - Length : in Natural); - -- Moves characters from one Chunk_Array to another, even when they - -- do not have the same chunk size - - - procedure Move (Target : in out Chunk_Array; - Source : in String; - Position : in Positive; - Chunk_Size : in Positive); - -- Writes the string in the chunk array, which must be large enough - - - procedure Move (Target : out String; - Source : in Chunk_Array; - From : in Positive); - -- Fills a string using characters from the Chunk_Array - - - procedure Move (Data : in out Chunk_Array; - Target_Position : in Positive; - Source_Position : in Positive; - Length : in Positive; - Chunk_Size : in Positive); - -- Move a slice of data inside a given chunk array - - - procedure Resize_Chunk (Chunk : in out String_Access; - Size : in Positive); - -- Resize a chunk to the target set - - - procedure Resize_Chunks (Data : in out Chunk_Array_Access; - Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive; - Can_Shrink : in Boolean := True); - -- Resize Data to fit Size characters - - - procedure Trim_Bounds (Source : in Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set; - Low : out Positive; - High : out Natural); - -- Compute slice bounds of the trimmed result - - - function Units_For (Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive) - return Natural; - pragma Inline (Units_For); - -- Return the number of allocation units in the last chunk - - - - --------------------------------------- - -- Chunked_String memory subprograms -- - --------------------------------------- - - function Allocated_Size (Source : in Chunked_String) return Natural is - begin - if Source.Data = null or else Source.Data'Last < 1 then - return 0; - end if; - - return (Source.Data'Last - 1) * Source.Chunk_Size - + Source.Data (Source.Data'Last)'Last; - end Allocated_Size; - - - - function Chunks_For (Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive) - return Natural is - begin - pragma Unreferenced (Allocation_Unit); - return (Size + Chunk_Size - 1) / Chunk_Size; - end Chunks_For; - - - - procedure Free (Data : in out Chunk_Array_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Chunk_Array, Chunk_Array_Access); - begin - if Data = null then - return; - end if; - for J in Data'Range loop - Free (Data (J)); - end loop; - Deallocate (Data); - end Free; - - - - procedure Resize_Chunk (Chunk : in out String_Access; - Size : in Positive) - is - New_Chunk : String_Access; - begin - if Size /= Chunk'Length then - New_Chunk := new String (1 .. Size); - if Size < Chunk'Length then - New_Chunk.all := Chunk (Chunk'First .. Chunk'First + Size - 1); - else - New_Chunk.all (1 .. Chunk'Length) := Chunk.all; - end if; - Free (Chunk); - Chunk := New_Chunk; - end if; - end Resize_Chunk; - - - - procedure Resize_Chunks (Data : in out Chunk_Array_Access; - Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive; - Can_Shrink : in Boolean := True) - is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Chunk_Array, Chunk_Array_Access); - - Chunk_Nb : constant Natural - := Chunks_For (Size, Chunk_Size, Allocation_Unit); - Last_Chunk_Size : constant Natural - := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; - begin - if Size = 0 then - if Can_Shrink then - Free (Data); - end if; - return; - end if; - pragma Assert (Chunk_Nb > 0); - - if Data = null or else Data'Length < Chunk_Nb then - declare - First_New : Positive := 1; - New_Data : Chunk_Array_Access := new Chunk_Array (1 .. Chunk_Nb); - begin - if Data /= null then - Resize_Chunk (Data (Data'Last), Chunk_Size); - New_Data (1 .. Data'Last) := Data.all; - First_New := Data'Last + 1; - Deallocate (Data); - end if; - Data := New_Data; - for J in First_New .. Data'Last - 1 loop - Data (J) := new String (1 .. Chunk_Size); - end loop; - Data (Data'Last) := new String (1 .. Last_Chunk_Size); - end; - elsif Data'Length > Chunk_Nb then - if Can_Shrink then - declare - New_Data : constant Chunk_Array_Access - := new Chunk_Array (1 .. Chunk_Nb); - begin - Resize_Chunk (Data (Chunk_Nb), Last_Chunk_Size); - for J in Chunk_Nb + 1 .. Data'Last loop - Free (Data (J)); - end loop; - New_Data.all := Data (1 .. Chunk_Nb); - Data := New_Data; - end; - end if; - else -- Data'Length = Chunk_Nb - if Last_Chunk_Size > Data (Data'Last).all'Last or Can_Shrink then - Resize_Chunk (Data (Data'Last), Last_Chunk_Size); - end if; - end if; - end Resize_Chunks; - - - - function Units_For (Size : in Natural; - Chunk_Size : in Positive; - Allocation_Unit : in Positive) - return Natural is - begin - return (((Size + Chunk_Size - 1) mod Chunk_Size + 1) - + Allocation_Unit - 1) / Allocation_Unit; - end Units_For; - - - - --------------------------- - -- Low-level subprograms -- - --------------------------- - - function Compare - (Left : in Chunk_Array; - Left_Size : in Natural; - Right : in Chunk_Array; - Right_Size : in Natural) - return Relation - is - L_Chunk : Positive := Left'First; - L_Pos : Positive := Left (L_Chunk).all'First; - L_Remain : Natural := Left_Size; - R_Chunk : Positive := Right'First; - R_Pos : Positive := Right (R_Chunk).all'First; - R_Remain : Natural := Right_Size; - Step : Positive; - begin - loop - Step := Positive'Min - (Natural'Min (Left (L_Chunk).all'Last - L_Pos + 1, - L_Remain), - Natural'Min (Right (R_Chunk).all'Last - R_Pos + 1, - R_Remain)); - declare - L_Part : String - renames Left (L_Chunk).all (L_Pos .. L_Pos + Step - 1); - R_Part : String - renames Right (R_Chunk).all (R_Pos .. R_Pos + Step - 1); - begin - if L_Part < R_Part then - return Lesser; - elsif L_Part > R_Part then - return Greater; - end if; - end; - - L_Remain := L_Remain - Step; - R_Remain := R_Remain - Step; - if L_Remain = 0 and R_Remain = 0 then - return Equal; - elsif L_Remain = 0 then - return Lesser; - elsif R_Remain = 0 then - return Greater; - end if; - - L_Pos := L_Pos + Step; - R_Pos := R_Pos + Step; - - if L_Pos > Left (L_Chunk).all'Last then - if L_Chunk = Left'Last then - if R_Pos <= Right (R_Chunk).all'Last - or R_Chunk < Right'Last - then - return Lesser; - else - return Equal; - end if; - end if; - L_Chunk := L_Chunk + 1; - L_Pos := Left (L_Chunk).all'First; - end if; - if R_Pos > Right (R_Chunk).all'Last then - if R_Chunk = Right'Last then - return Greater; - end if; - R_Chunk := R_Chunk + 1; - R_Pos := Right (R_Chunk).all'First; - end if; - end loop; - end Compare; - - - - function Compare - (Left : in Chunk_Array_Access; - Left_Size : in Natural; - Right : in Chunk_Array_Access; - Right_Size : in Natural) - return Relation is - begin - if Left = null or Left_Size = 0 then - if Right = null or Right_Size = 0 then - return Equal; - else - return Lesser; - end if; - else - if Right = null or Right_Size = 0 then - return Greater; - else - return Compare (Left.all, Left_Size, Right.all, Right_Size); - end if; - end if; - end Compare; - - - - function Compare - (Left : in Chunk_Array; - Left_Size : in Natural; - Right : in String) - return Relation - is - Chunk : Positive := Left'First; - L_Pos : Positive := Left (Chunk).all'First; - L_Remain : Natural := Left_Size; - R_Pos : Positive := Right'First; - Step : Positive; - begin - loop - Step - := Positive'Min (Positive'Min (Left (Chunk).all'Last - L_Pos + 1, - L_Remain), - Right'Last - R_Pos + 1); - declare - L_Part : String - renames Left (Chunk).all (L_Pos .. L_Pos + Step - 1); - R_Part : String - renames Right (R_Pos .. R_Pos + Step - 1); - begin - if L_Part < R_Part then - return Lesser; - elsif L_Part > R_Part then - return Greater; - end if; - end; - - L_Remain := L_Remain - Step; - if L_Remain = 0 then - if R_Pos + Step > Right'Last then - return Equal; - else - return Lesser; - end if; - end if; - - L_Pos := L_Pos + Step; - R_Pos := R_Pos + Step; - - if L_Pos > Left (Chunk).all'Last then - if Chunk = Left'Last then - if R_Pos <= Right'Last then - return Lesser; - else - return Equal; - end if; - end if; - Chunk := Chunk + 1; - L_Pos := Left (Chunk).all'First; - end if; - if R_Pos > Right'Last then - return Greater; - end if; - end loop; - end Compare; - - - - function Compare - (Left : in Chunk_Array_Access; - Left_Size : in Natural; - Right : in String) - return Relation is - begin - if Left = null or Left_Size = 0 then - if Right'Length = 0 then - return Equal; - else - return Lesser; - end if; - else - if Right'Length = 0 then - return Greater; - else - return Compare (Left.all, Left_Size, Right); - end if; - end if; - end Compare; - - - - procedure Fill (Data : in out Chunk_Array; - From : in Positive; - Count : in Natural; - C : in Character; - Chunk_Size : in Positive) - is - Chunk : Positive := (From - 1) / Chunk_Size + 1; - Offset : Positive := (From - 1) mod Chunk_Size + 1; - Done : Natural := 0; - Step : Positive; - begin - while Done < Count loop - Step := Positive'Min (Count - Done, - Data (Chunk).all'Last - Offset + 1); - Data (Chunk).all (Offset .. Offset + Step - 1) - := Ada.Strings.Fixed."*" (Step, C); - Chunk := Chunk + 1; - Offset := 1; - Done := Done + Step; - end loop; - end Fill; - - - - function Is_Valid (Source : in Chunked_String) return Boolean is - begin - -- Null data is only acceptable when the string is empty. - if Source.Data = null then - return Source.Size = 0; - end if; - - -- Data array must contain non-null chunks of even size - declare - D : Chunk_Array renames Source.Data.all; - begin - if D'First /= 1 then - return False; - end if; - for J in D'Range loop - if D (J) = null then - return False; - end if; - - if D (J).all'First /= 1 or - (J < D'Last and D (J).all'Last /= Source.Chunk_Size) - then - return False; - end if; - end loop; - end; - - -- Real size must be smaller than allocated size - if Source.Size > Allocated_Size (Source) then - return False; - end if; - - return True; - end Is_Valid; - - - - procedure Move (Target : in out Chunk_Array; - Target_Position : in Positive; - Source : in out Chunk_Array; - Source_Position : in Positive; - Length : in Natural) - is - Count : Natural := 0; - S_Chunk : Positive; - S_Pos : Positive; - T_Chunk : Positive; - T_Pos : Positive; - begin - S_Chunk := Target'First; - S_Pos := 1; - while S_Pos + Source (S_Chunk).all'Length <= Source_Position loop - S_Pos := S_Pos + Source (S_Chunk).all'Length; - S_Chunk := S_Chunk + 1; - end loop; - S_Pos := Source_Position + 1 - S_Pos; - - T_Chunk := Target'First; - T_Pos := 1; - while T_Pos + Target (T_Chunk).all'Length <= Target_Position loop - T_Pos := T_Pos + Target (T_Chunk).all'Length; - T_Chunk := T_Chunk + 1; - end loop; - T_Pos := Target_Position + 1 - T_Pos; - - while Count < Length loop - declare - S_String : String renames Source (S_Chunk).all; - T_String : String renames Target (T_Chunk).all; - Step_C : constant Positive := Length - Count; - Step_S : constant Positive := S_String'Last - S_Pos + 1; - Step_T : constant Positive := T_String'Last - T_Pos + 1; - Step : constant Positive - := Positive'Min (Step_C, Positive'Min (Step_S, Step_T)); - begin - T_String (T_Pos .. T_Pos + Step - 1) - := S_String (S_Pos .. S_Pos + Step - 1); - Count := Count + Step; - exit when Count >= Length; - S_Pos := S_Pos + Step; - T_Pos := T_Pos + Step; - if S_Pos > S_String'Last then - S_Chunk := S_Chunk + 1; - S_Pos := Source (S_Chunk).all'First; - end if; - if T_Pos > T_String'Last then - T_Chunk := T_Chunk + 1; - T_Pos := Target (T_Chunk).all'First; - end if; - end; - end loop; - end Move; - - - - procedure Move (Target : in out Chunk_Array; - Source : in String; - Position : in Positive; - Chunk_Size : in Positive) - is - Last_Position : constant Positive := Position + Source'Length - 1; - First_Chunk : constant Positive := (Position - 1) / Chunk_Size + 1; - First_Offset : constant Positive := (Position - 1) mod Chunk_Size + 1; - Last_Chunk : constant Positive - := (Last_Position - 1) / Chunk_Size + 1; - Last_Offset : constant Positive - := (Last_Position - 1) mod Chunk_Size + 1; - Current : Positive; - begin - if First_Chunk = Last_Chunk then - Target (First_Chunk).all (First_Offset .. Last_Offset) := Source; - else - Current := Source'First + Chunk_Size - First_Offset + 1; - Target (First_Chunk).all (First_Offset .. Chunk_Size) - := Source (Source'First .. Current - 1); - for J in First_Chunk + 1 .. Last_Chunk - 1 loop - Target (J).all := Source (Current .. Current + Chunk_Size - 1); - Current := Current + Chunk_Size; - end loop; - Target (Last_Chunk).all (1 .. Last_Offset) - := Source (Current .. Source'Last); - end if; - end Move; - - - - procedure Move (Target : out String; - Source : in Chunk_Array; - From : in Positive) - is - T_Pos : Positive := Target'First; - S_Pos : Positive := 1; - Chunk : Positive := 1; - Step : Positive; - begin - while S_Pos + Source (Chunk).all'Length <= From loop - S_Pos := S_Pos + Source (Chunk).all'Length; - Chunk := Chunk + 1; - end loop; - S_Pos := From - S_Pos + 1; - - Step := Source (Chunk).all'Last - S_Pos + 1; - if Target'Length <= Step then - Target := Source (Chunk).all (S_Pos .. S_Pos + Target'Length - 1); - return; - end if; - - Target (T_Pos .. T_Pos + Step - 1) - := Source (Chunk).all (S_Pos .. Source (Chunk).all'Last); - T_Pos := T_Pos + Step; - Chunk := Chunk + 1; - - while T_Pos <= Target'Last loop - Step := Positive'Min (Source (Chunk).all'Length, - Target'Last - T_Pos + 1); - Target (T_Pos .. T_Pos + Step - 1) - := Source (Chunk).all (1 .. Step); - T_Pos := T_Pos + Step; - Chunk := Chunk + 1; - end loop; - end Move; - - - - procedure Move (Data : in out Chunk_Array; - Target_Position : in Positive; - Source_Position : in Positive; - Length : in Positive; - Chunk_Size : in Positive) is - begin - if Target_Position < Source_Position then - declare - S_Chunk : Positive := (Source_Position - 1) / Chunk_Size + 1; - S_Pos : Positive := (Source_Position - 1) mod Chunk_Size + 1; - T_Chunk : Positive := (Target_Position - 1) / Chunk_Size + 1; - T_Pos : Positive := (Target_Position - 1) mod Chunk_Size + 1; - Count : Natural := 0; - Step : Positive; - begin - while Count < Length loop - Step := Positive'Min - (Positive'Min (Data (S_Chunk).all'Last - S_Pos + 1, - Data (T_Chunk).all'Last - T_Pos + 1), - Length - Count); - Data (T_Chunk).all (T_Pos .. T_Pos + Step - 1) - := Data (S_Chunk).all (S_Pos .. S_Pos + Step - 1); - Count := Count + Step; - - S_Pos := S_Pos + Step; - if S_Pos > Chunk_Size then - S_Chunk := S_Chunk + 1; - S_Pos := 1; - end if; - - T_Pos := T_Pos + Step; - if T_Pos > Chunk_Size then - T_Chunk := T_Chunk + 1; - T_Pos := 1; - end if; - end loop; - end; - elsif Target_Position > Source_Position then - declare - S_End : constant Positive := Source_Position + Length - 1; - T_End : constant Positive := Target_Position + Length - 1; - S_Chunk : Positive := (S_End - 1) / Chunk_Size + 1; - S_Pos : Positive := (S_End - 1) mod Chunk_Size + 1; - T_Chunk : Positive := (T_End - 1) / Chunk_Size + 1; - T_Pos : Positive := (T_End - 1) mod Chunk_Size + 1; - Count : Natural := 0; - Step : Positive; - begin - loop - Step := Positive'Min (Positive'Min (S_Pos, T_Pos), - Length - Count); - Data (T_Chunk).all (T_Pos - Step + 1 .. T_Pos) - := Data (S_Chunk).all (S_Pos - Step + 1 .. S_Pos); - Count := Count + Step; - exit when Count = Length; - pragma Assert (Count < Length); - - if S_Pos <= Step then - S_Chunk := S_Chunk - 1; - S_Pos := Chunk_Size; - else - S_Pos := S_Pos - Step; - end if; - - if T_Pos <= Step then - T_Chunk := T_Chunk - 1; - T_Pos := Chunk_Size; - else - T_Pos := T_Pos - Step; - end if; - end loop; - end; - end if; - end Move; - - - - -------------------------------------------------- - -- Public interface specific to Chunked_Strings -- - -------------------------------------------------- - - - function Build (Depth : Positive) - return Natools.Accumulators.String_Accumulator'Class - is - pragma Unreferenced (Depth); - begin - return Null_Chunked_String; - end Build; - - - - function Duplicate (Source : in Chunked_String) return Chunked_String is - Data : Chunk_Array_Access := null; - begin - if Source.Data /= null then - Data := new Chunk_Array (Source.Data'Range); - for J in Source.Data'Range loop - Data (J) := new String'(Source.Data (J).all); - end loop; - end if; - - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Source.Chunk_Size, - Allocation_Unit => Source.Allocation_Unit, - Size => Source.Size, - Data => Data); - end Duplicate; - - - - procedure Hard_Reset (Str : in out Chunked_String) is - begin - Free (Str.Data); - end Hard_Reset; - - - - procedure Soft_Reset (Str : in out Chunked_String) is - begin - Str.Size := 0; - end Soft_Reset; - - - - procedure To_String (Source : Chunked_String; Output : out String) is - Position : Positive := Output'First; - Step : Positive; - begin - if Source.Size > 0 then - for J in Source.Data'Range loop - Step := Positive'Min (Source.Data (J).all'Length, - Source.Size - Position + 1); - Output (Position .. Position + Step - 1) - := Source.Data (J).all (1 .. Step); - Position := Position + Step; - exit when Position > Source.Size; - end loop; - pragma Assert (Position = Source.Size + 1); - end if; - end To_String; - - - - ------------------------------------------- - -- String_Accumulator specific interface -- - ------------------------------------------- - - - function Tail (Source : in Chunked_String; Size : in Natural) - return String - is - Actual_Size : constant Natural := Natural'Min (Size, Source.Size); - begin - return Slice (Source, Source.Size - Actual_Size + 1, Source.Size); - end Tail; - - - - procedure Unappend (From : in out Chunked_String; Text : in String) is - begin - if Text'Length <= From.Size - and then String'(Tail (From, Text'Length)) = Text - then - From.Size := From.Size - Text'Length; - end if; - end Unappend; - - - - ------------------------ - -- Standard interface -- - ------------------------ - - function Length (Source : in Chunked_String) return Natural is - begin - return Source.Size; - end Length; - - - - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - - procedure Free (X : in out String_Access) is - begin - Deallocate (X); - end Free; - - - procedure Free_Extra_Memory (From : in out Chunked_String) is - begin - Resize_Chunks (From.Data, From.Size, - From.Chunk_Size, From.Allocation_Unit, - Can_Shrink => True); - end Free_Extra_Memory; - - - procedure Preallocate (Str : in out Chunked_String; Size : Natural) is - begin - Resize_Chunks (Str.Data, Size, Str.Chunk_Size, Str.Allocation_Unit, - Can_Shrink => False); - end Preallocate; - - - function To_Chunked_String - (Source : in String; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String - is - Data : Chunk_Array_Access := null; - begin - if Source'Length > 0 then - Resize_Chunks (Data, Source'Length, Chunk_Size, Allocation_Unit); - Move (Data.all, Source, 1, Chunk_Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Source'Length, - Data => Data); - end To_Chunked_String; - - - - function To_Chunked_String - (Length : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String - is - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Length, Chunk_Size, Allocation_Unit); - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Length, - Data => Data); - end To_Chunked_String; - - - - function To_String (Source : in Chunked_String) return String is - Value : String (1 .. Source.Size); - begin - To_String (Source, Value); - return Value; - end To_String; - - - - procedure Set_Chunked_String - (Target : out Chunked_String; - Source : in String; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) is - begin - Resize_Chunks (Target.Data, Source'Length, - Chunk_Size, Allocation_Unit, - Can_Shrink => True); - Target.Chunk_Size := Chunk_Size; - Target.Allocation_Unit := Allocation_Unit; - Target.Size := Source'Length; - if Target.Size > 0 then - Move (Target.Data.all, Source, 1, Chunk_Size); - end if; - end Set_Chunked_String; - - - - procedure Append (Source : in out Chunked_String; - New_Item : in Chunked_String) - is - New_Size : constant Natural := Source.Size + New_Item.Size; - begin - Resize_Chunks (Source.Data, New_Size, - Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - Move (Source.Data.all, Source.Size + 1, - New_Item.Data.all, 1, - New_Item.Size); - Source.Size := New_Size; - end Append; - - - - procedure Append (Source : in out Chunked_String; - New_Item : in String) - is - New_Size : constant Natural := Source.Size + New_Item'Length; - begin - Resize_Chunks (Source.Data, New_Size, - Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - Move (Source.Data.all, New_Item, Source.Size + 1, Source.Chunk_Size); - Source.Size := New_Size; - end Append; - - - - procedure Append (Source : in out Chunked_String; - New_Item : in Character) - is - S : constant String (1 .. 1) := (1 => New_Item); - begin - Append (Source, S); - end Append; - - - - function "&" (Left, Right : in Chunked_String) - return Chunked_String - is - Size : constant Natural := Left.Size + Right.Size; - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); - if Left.Size > 0 then - Move (Data.all, 1, Left.Data.all, 1, Left.Size); - end if; - if Right.Size > 0 then - Move (Data.all, 1 + Left.Size, Right.Data.all, 1, Right.Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Default_Chunk_Size, - Allocation_Unit => Default_Allocation_Unit, - Size => Size, - Data => Data); - end "&"; - - - - function "&" (Left : in Chunked_String; Right : in String) - return Chunked_String - is - Size : constant Natural := Left.Size + Right'Length; - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); - if Left.Size > 0 then - Move (Data.all, 1, Left.Data.all, 1, Left.Size); - end if; - if Right'Length > 0 then - Move (Data.all, Right, 1 + Left.Size, Default_Chunk_Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Default_Chunk_Size, - Allocation_Unit => Default_Allocation_Unit, - Size => Size, - Data => Data); - end "&"; - - - - function "&" (Left : in String; Right : in Chunked_String) - return Chunked_String - is - Size : constant Natural := Left'Length + Right.Size; - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); - if Left'Length > 0 then - Move (Data.all, Left, 1, Default_Chunk_Size); - end if; - if Right.Size > 0 then - Move (Data.all, 1 + Left'Length, Right.Data.all, 1, Right.Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Default_Chunk_Size, - Allocation_Unit => Default_Allocation_Unit, - Size => Size, - Data => Data); - end "&"; - - - - function "&" (Left : in Chunked_String; Right : in Character) - return Chunked_String - is - Size : constant Natural := Left.Size + 1; - Allocation_Unit : constant Positive := Default_Allocation_Unit; - Chunk_Size : constant Positive := Default_Chunk_Size; - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); - if Left.Size > 0 then - Move (Data.all, 1, Left.Data.all, 1, Left.Size); - end if; - declare - Position : constant Positive := Left.Size + 1; - Chunk : constant Positive := (Position - 1) / Chunk_Size + 1; - Offset : constant Positive := (Position - 1) mod Chunk_Size + 1; - begin - Data (Chunk).all (Offset) := Right; - end; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Size, - Data => Data); - end "&"; - - - - function "&" (Left : in Character; Right : in Chunked_String) - return Chunked_String - is - Size : constant Natural := 1 + Right.Size; - Data : Chunk_Array_Access := null; - begin - Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); - Data (1).all (1) := Left; - if Right.Size > 0 then - Move (Data.all, 2, Right.Data.all, 1, Right.Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Default_Chunk_Size, - Allocation_Unit => Default_Allocation_Unit, - Size => Size, - Data => Data); - end "&"; - - - - function Element (Source : in Chunked_String; - Index : in Positive) - return Character - is - Chunk : constant Positive := (Index - 1) / Source.Chunk_Size + 1; - Offset : constant Positive := (Index - 1) mod Source.Chunk_Size + 1; - begin - if Index > Source.Size then - raise Ada.Strings.Index_Error; - end if; - return Source.Data (Chunk).all (Offset); - end Element; - - - - procedure Replace_Element (Source : in out Chunked_String; - Index : in Positive; - By : in Character) - is - Chunk : constant Positive := (Index - 1) / Source.Chunk_Size + 1; - Offset : constant Positive := (Index - 1) mod Source.Chunk_Size + 1; - begin - if Index > Source.Size then - raise Ada.Strings.Index_Error; - end if; - Source.Data (Chunk).all (Offset) := By; - end Replace_Element; - - - - function Slice (Source : in Chunked_String; - Low : in Positive; - High : in Natural) - return String - is - Returned : String (Low .. High); - begin - if Low > Source.Size + 1 or High > Source.Size then - raise Ada.Strings.Index_Error; - end if; - if High >= Low then - Move (Returned, Source.Data.all, Low); - end if; - return Returned; - end Slice; - - - - function Chunked_Slice - (Source : in Chunked_String; - Low : in Positive; - High : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String - is - Data : Chunk_Array_Access := null; - Size : Natural := 0; - begin - if Low > Source.Size + 1 or High > Source.Size then - raise Ada.Strings.Index_Error; - end if; - if Low <= High then - Size := High - Low + 1; - Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); - Move (Data.all, 1, Source.Data.all, Low, Size); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Size, - Data => Data); - end Chunked_Slice; - - - - procedure Chunked_Slice - (Source : in Chunked_String; - Target : out Chunked_String; - Low : in Positive; - High : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) is - begin - if Low > Source.Size + 1 or High > Source.Size then - raise Ada.Strings.Index_Error; - end if; - Target.Chunk_Size := Chunk_Size; - Target.Allocation_Unit := Allocation_Unit; - if Low <= High then - Target.Size := High - Low + 1; - Resize_Chunks (Target.Data, Target.Size, - Chunk_Size, Allocation_Unit, - Can_Shrink => True); - Move (Target.Data.all, 1, Source.Data.all, Low, Target.Size); - else - Target.Size := 0; - Target.Data := null; - end if; - end Chunked_Slice; - - - - function "=" (Left, Right : in Chunked_String) return Boolean is - begin - return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Equal; - end "="; - - - - function "=" (Left : in Chunked_String; Right : in String) - return Boolean is - begin - return Compare (Left.Data, Left.Size, Right) = Equal; - end "="; - - - - function "=" (Left : in String; Right : in Chunked_String) - return Boolean is - begin - return Compare (Right.Data, Right.Size, Left) = Equal; - end "="; - - - - function "<" (Left, Right : in Chunked_String) return Boolean is - begin - return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Lesser; - end "<"; - - - - function "<" (Left : in Chunked_String; Right : in String) - return Boolean is - begin - return Compare (Left.Data, Left.Size, Right) = Lesser; - end "<"; - - - - function "<" (Left : in String; Right : in Chunked_String) - return Boolean is - begin - return Compare (Right.Data, Right.Size, Left) = Greater; - end "<"; - - - - function "<=" (Left, Right : in Chunked_String) return Boolean is - begin - return Compare (Left.Data, Left.Size, Right.Data, Right.Size) /= Greater; - end "<="; - - - - function "<=" (Left : in Chunked_String; Right : in String) - return Boolean is - begin - return Compare (Left.Data, Left.Size, Right) /= Greater; - end "<="; - - - - function "<=" (Left : in String; Right : in Chunked_String) - return Boolean is - begin - return Compare (Right.Data, Right.Size, Left) /= Lesser; - end "<="; - - - - function ">" (Left, Right : in Chunked_String) return Boolean is - begin - return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Greater; - end ">"; - - - - function ">" (Left : in Chunked_String; Right : in String) - return Boolean is - begin - return Compare (Left.Data, Left.Size, Right) = Greater; - end ">"; - - - - function ">" (Left : in String; Right : in Chunked_String) - return Boolean is - begin - return Compare (Right.Data, Right.Size, Left) = Lesser; - end ">"; - - - - function ">=" (Left, Right : in Chunked_String) return Boolean is - begin - return Compare (Left.Data, Left.Size, Right.Data, Right.Size) /= Lesser; - end ">="; - - - - function ">=" (Left : in Chunked_String; Right : in String) - return Boolean is - begin - return Compare (Left.Data, Left.Size, Right) /= Lesser; - end ">="; - - - - function ">=" (Left : in String; Right : in Chunked_String) - return Boolean is - begin - return Compare (Right.Data, Right.Size, Left) /= Greater; - end ">="; - - - - function Index_Gen - (Source : Chunked_String; - Pattern : String; - From : Positive; - Going : Ada.Strings.Direction; - Map : Map_Type) - return Natural is - begin - if Pattern = "" then - raise Ada.Strings.Pattern_Error; - end if; - if Source.Size = 0 and From = 1 then - return 0; - end if; - if From > Source.Size then - raise Ada.Strings.Index_Error; - end if; - - declare - Chunk : Positive := (From - 1) / Source.Chunk_Size + 1; - Offset : Positive := (From - 1) mod Source.Chunk_Size + 1; - Buffer : String (1 .. Source.Chunk_Size + Pattern'Length - 1); - Result : Natural; - Span : Positive; - begin - case (Going) is - when Ada.Strings.Forward => - while (Chunk - 1) * Source.Chunk_Size + Pattern'Length - <= Source.Size - loop - Span := Positive'Min - (Source.Chunk_Size + Pattern'Length - 1, - Source.Size - (Chunk - 1) * Source.Chunk_Size); - Move (Buffer (1 .. Span), - Source.Data.all, - (Chunk - 1) * Source.Chunk_Size + 1); - Result := Index (Buffer (1 .. Span), - Pattern, Offset, Going, Map); - if Result /= 0 then - return (Chunk - 1) * Source.Chunk_Size + Result; - end if; - Chunk := Chunk + 1; - Offset := 1; - end loop; - return 0; - when Ada.Strings.Backward => - loop - Span := Positive'Min - (Source.Chunk_Size + Pattern'Length - 1, - Source.Size - (Chunk - 1) * Source.Chunk_Size); - Move (Buffer (1 .. Span), - Source.Data.all, - (Chunk - 1) * Source.Chunk_Size + 1); - Result := Index (Buffer (1 .. Span), - Pattern, Offset, Going, Map); - if Result /= 0 then - return (Chunk - 1) * Source.Chunk_Size + Result; - end if; - exit when Chunk = 1; - Chunk := Chunk - 1; - Offset := Positive'Min (Source.Chunk_Size + Pattern'Length - 1, - Source.Chunk_Size + Offset); - end loop; - return 0; - end case; - end; - end Index_Gen; - - - - function Index_Mapping is - new Index_Gen (Maps.Character_Mapping, Ada.Strings.Fixed.Index); - - function Index (Source : in Chunked_String; - Pattern : in String; - From : in Positive; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural - renames Index_Mapping; - - - - function Index_Mapping_Function is - new Index_Gen (Maps.Character_Mapping_Function, Ada.Strings.Fixed.Index); - - function Index (Source : in Chunked_String; - Pattern : in String; - From : in Positive; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping_Function) - return Natural - renames Index_Mapping_Function; - - - - function Index (Source : in Chunked_String; - Pattern : in String; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural is - begin - case (Going) is - when Ada.Strings.Forward => - return Index (Source, Pattern, 1, Going, Mapping); - when Ada.Strings.Backward => - return Index (Source, Pattern, Source.Size, Going, Mapping); - end case; - end Index; - - - - function Index (Source : in Chunked_String; - Pattern : in String; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping_Function) - return Natural is - begin - case (Going) is - when Ada.Strings.Forward => - return Index (Source, Pattern, 1, Going, Mapping); - when Ada.Strings.Backward => - return Index (Source, Pattern, Source.Size, Going, Mapping); - end case; - end Index; - - - - function Index (Source : in Chunked_String; - Set : in Maps.Character_Set; - From : in Positive; - Test : in Ada.Strings.Membership := Ada.Strings.Inside; - Going : in Ada.Strings.Direction := Ada.Strings.Forward) - return Natural - is - Chunk : Positive := (From - 1) / Source.Chunk_Size + 1; - Offset : Positive := (From - 1) mod Source.Chunk_Size + 1; - Result : Natural; - begin - if From > Source.Size then - raise Ada.Strings.Index_Error; - end if; - - case (Going) is - when Ada.Strings.Forward => - loop - Result := Ada.Strings.Fixed.Index - (Source.Data (Chunk).all, Set, Offset, Test, Going); - if Result /= 0 then - return (Chunk - 1) * Source.Chunk_Size + Result; - end if; - if Chunk = Source.Data'Last then - return 0; - end if; - Chunk := Chunk + 1; - Offset := 1; - end loop; - when Ada.Strings.Backward => - loop - Result := Ada.Strings.Fixed.Index - (Source.Data (Chunk).all, Set, Offset, Test, Going); - if Result /= 0 then - return (Chunk - 1) * Source.Chunk_Size + Result; - end if; - if Chunk = Source.Data'First then - return 0; - end if; - Chunk := Chunk - 1; - Offset := Source.Chunk_Size; - end loop; - end case; - end Index; - - - - function Index (Source : in Chunked_String; - Set : in Maps.Character_Set; - Test : in Ada.Strings.Membership := Ada.Strings.Inside; - Going : in Ada.Strings.Direction := Ada.Strings.Forward) - return Natural is - begin - case Going is - when Ada.Strings.Forward => - return Index (Source, Set, 1, Test, Going); - when Ada.Strings.Backward => - return Index (Source, Set, Source.Size, Test, Going); - end case; - end Index; - - - - function Index_Non_Blank (Source : in Chunked_String; - From : in Positive; - Going : in Ada.Strings.Direction - := Ada.Strings.Forward) - return Natural is - begin - return Index (Source, - Maps.To_Set (Ada.Strings.Space), - From, - Ada.Strings.Outside, - Going); - end Index_Non_Blank; - - - - function Index_Non_Blank (Source : in Chunked_String; - Going : in Ada.Strings.Direction - := Ada.Strings.Forward) - return Natural is - begin - return Index (Source, - Maps.To_Set (Ada.Strings.Space), - Ada.Strings.Outside, - Going); - end Index_Non_Blank; - - - - function Count_Gen (Source : in Chunked_String; - Pattern : in String; - Mapping : in Map_Type) - return Natural - is - Buffer : String (1 .. Source.Chunk_Size + Pattern'Length - 1); - Result : Natural := 0; - Step : Positive; - begin - if Pattern = "" then - raise Ada.Strings.Pattern_Error; - end if; - if Source.Size < Pattern'Length then - return 0; - end if; - - for J in Source.Data'Range loop - Step := Positive'Min (Source.Size - (J - 1) * Source.Chunk_Size, - Source.Chunk_Size + Pattern'Length - 1); - Move (Buffer (1 .. Step), - Source.Data.all, - (J - 1) * Source.Chunk_Size + 1); - Result := Result + Count (Buffer (1 .. Step), - Pattern, - Mapping); - end loop; - return Result; - end Count_Gen; - - function Count_Mapping is - new Count_Gen (Maps.Character_Mapping, Ada.Strings.Fixed.Count); - - function Count (Source : in Chunked_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural - renames Count_Mapping; - - function Count_Mapping_Function is - new Count_Gen (Maps.Character_Mapping_Function, Ada.Strings.Fixed.Count); - - function Count (Source : in Chunked_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping_Function) - return Natural - renames Count_Mapping_Function; - - - - function Count (Source : in Chunked_String; - Set : in Maps.Character_Set) - return Natural - is - Result : Natural := 0; - Done : Natural := 0; - begin - if Source.Size > 0 then - for C in Source.Data'Range loop - declare - Chunk : String renames Source.Data (C).all; - Step : constant Natural - := Natural'Min (Source.Size - Done, Chunk'Length); - begin - Result := Result + Ada.Strings.Fixed.Count - (Chunk (Chunk'First .. Chunk'First + Step - 1), Set); - Done := Done + Step; - end; - end loop; - end if; - return Result; - end Count; - - - - procedure Find_Token (Source : in Chunked_String; - Set : in Maps.Character_Set; - Test : in Ada.Strings.Membership; - First : out Positive; - Last : out Natural) - is - function Invert (M : Ada.Strings.Membership) - return Ada.Strings.Membership; - pragma Inline (Invert); - - N : Natural; - - function Invert (M : Ada.Strings.Membership) - return Ada.Strings.Membership - is - use Ada.Strings; - begin - case M is - when Inside => return Outside; - when Outside => return Inside; - end case; - end Invert; - begin - N := Index (Source, Set, Test); - - if N = 0 then - First := 1; - Last := 0; - else - First := N; - N := Index (Source, Set, First, Invert (Test)); - if N = 0 then - Last := Source.Size; - else - Last := N - 1; - end if; - end if; - end Find_Token; - - - - -- String translation subprograms - - function Translate (Source : in Chunked_String; - Mapping : in Maps.Character_Mapping) - return Chunked_String - is - Data : Chunk_Array_Access := null; - begin - if Source.Data /= null then - Data := new Chunk_Array (Source.Data'Range); - for J in Source.Data'Range loop - Data (J) := new String (Source.Data (J).all'Range); - Data (J).all := Fixed.Translate (Source.Data (J).all, Mapping); - end loop; - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Source.Chunk_Size, - Allocation_Unit => Source.Allocation_Unit, - Size => Source.Size, - Data => Data); - end Translate; - - - - procedure Translate (Source : in out Chunked_String; - Mapping : in Maps.Character_Mapping) is - begin - if Source.Data /= null then - for J in Source.Data'Range loop - Fixed.Translate (Source.Data (J).all, Mapping); - end loop; - end if; - end Translate; - - - - function Translate (Source : in Chunked_String; - Mapping : in Maps.Character_Mapping_Function) - return Chunked_String - is - Data : Chunk_Array_Access := null; - begin - if Source.Data /= null then - Data := new Chunk_Array (Source.Data'Range); - for J in Source.Data'Range loop - Data (J) := new String (Source.Data (J).all'Range); - Data (J).all := Fixed.Translate (Source.Data (J).all, Mapping); - end loop; - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Source.Chunk_Size, - Allocation_Unit => Source.Allocation_Unit, - Size => Source.Size, - Data => Data); - end Translate; - - - - procedure Translate (Source : in out Chunked_String; - Mapping : in Maps.Character_Mapping_Function) is - begin - if Source.Data /= null then - for J in Source.Data'Range loop - Fixed.Translate (Source.Data (J).all, Mapping); - end loop; - end if; - end Translate; - - - - -- String transformation subprograms - - function Replace_Slice (Source : in Chunked_String; - Low : in Positive; - High : in Natural; - By : in String) - return Chunked_String - is - Size : Natural := 0; - Data : Chunk_Array_Access := null; - Hi : Natural := High; - begin - if Low > Source.Size + 1 then - raise Ada.Strings.Index_Error; - end if; - - if High < Low then - Hi := Low - 1; - end if; - - Size := (Low - 1) + By'Length + (Source.Size - Hi); - Resize_Chunks (Data, Size, Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - if Low > 1 then - Move (Data.all, 1, Source.Data.all, 1, Low - 1); - end if; - if By'Length > 0 then - Move (Data.all, By, Low, Source.Chunk_Size); - end if; - if Hi < Source.Size then - Move (Data.all, Low + By'Length, Source.Data.all, Hi + 1, - Source.Size - Hi); - end if; - - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Source.Chunk_Size, - Allocation_Unit => Source.Allocation_Unit, - Size => Size, - Data => Data); - end Replace_Slice; - - - - procedure Replace_Slice (Source : in out Chunked_String; - Low : in Positive; - High : in Natural; - By : in String) - is - Size : Natural := 0; - Hi : Natural := High; - begin - if Low > Source.Size + 1 then - raise Ada.Strings.Index_Error; - end if; - - if High < Low then - Hi := Low - 1; - end if; - - Size := (Low - 1) + By'Length + (Source.Size - Hi); - Resize_Chunks (Source.Data, Size, - Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - if Hi < Source.Size and Low + By'Length /= Hi + 1 then - Move (Data => Source.Data.all, - Target_Position => Low + By'Length, - Source_Position => Hi + 1, - Length => Source.Size - Hi, - Chunk_Size => Source.Chunk_Size); - end if; - if By'Length > 0 then - Move (Source.Data.all, By, Low, Source.Chunk_Size); - end if; - Source.Size := Size; - end Replace_Slice; - - - - function Insert (Source : in Chunked_String; - Before : in Positive; - New_Item : in String) - return Chunked_String is - begin - return Replace_Slice (Source, Before, Before - 1, New_Item); - end Insert; - - - - procedure Insert (Source : in out Chunked_String; - Before : in Positive; - New_Item : in String) is - begin - Replace_Slice (Source, Before, Before - 1, New_Item); - end Insert; - - - - function Overwrite (Source : in Chunked_String; - Position : in Positive; - New_Item : in String) - return Chunked_String is - begin - return Replace_Slice (Source, Position, Source.Size, New_Item); - end Overwrite; - - - - procedure Overwrite (Source : in out Chunked_String; - Position : in Positive; - New_Item : in String) is - begin - Replace_Slice (Source, - Low => Position, - High => Natural'Min (Source.Size, - Position + New_Item'Length - 1), - By => New_Item); - end Overwrite; - - - - function Delete (Source : in Chunked_String; - From : in Positive; - Through : in Natural) - return Chunked_String is - begin - if From <= Through then - return Replace_Slice (Source, From, Through, ""); - else - return Duplicate (Source); - end if; - end Delete; - - - - procedure Delete (Source : in out Chunked_String; - From : in Positive; - Through : in Natural) is - begin - if From <= Through then - Replace_Slice (Source, From, Through, ""); - end if; - end Delete; - - - - function Trim (Source : in Chunked_String; - Side : in Ada.Strings.Trim_End) - return Chunked_String is - begin - case Side is - when Ada.Strings.Left => - return Trim (Source, - Maps.To_Set (Ada.Strings.Space), - Maps.Null_Set); - when Ada.Strings.Right => - return Trim (Source, - Maps.Null_Set, - Maps.To_Set (Ada.Strings.Space)); - when Ada.Strings.Both => - return Trim (Source, - Maps.To_Set (Ada.Strings.Space), - Maps.To_Set (Ada.Strings.Space)); - end case; - end Trim; - - - - procedure Trim (Source : in out Chunked_String; - Side : in Ada.Strings.Trim_End) is - begin - case Side is - when Ada.Strings.Left => - Trim (Source, - Maps.To_Set (Ada.Strings.Space), - Maps.Null_Set); - when Ada.Strings.Right => - Trim (Source, - Maps.Null_Set, - Maps.To_Set (Ada.Strings.Space)); - when Ada.Strings.Both => - Trim (Source, - Maps.To_Set (Ada.Strings.Space), - Maps.To_Set (Ada.Strings.Space)); - end case; - end Trim; - - - - procedure Trim_Bounds (Source : in Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set; - Low : out Positive; - High : out Natural) - is - Chunk : Positive; - begin - Low := 1; - High := Source.Size; - - Chunk := 1; - while Low <= High and then - Maps.Is_In (Source.Data (Chunk).all - (Low - (Chunk - 1) * Source.Chunk_Size), - Left) - loop - Low := Low + 1; - if Low mod Source.Chunk_Size = 1 then - Chunk := Chunk + 1; - end if; - end loop; - - if High > 0 then - Chunk := (High - 1) / Source.Chunk_Size + 1; - while Low <= High and then - Maps.Is_In (Source.Data (Chunk).all - (High - (Chunk - 1) * Source.Chunk_Size), - Right) - loop - High := High - 1; - if High mod Source.Chunk_Size = 0 then - Chunk := Chunk - 1; - end if; - end loop; - end if; - end Trim_Bounds; - - - - function Trim (Source : in Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set) - return Chunked_String - is - Low : Positive; - High : Natural; - begin - Trim_Bounds (Source, Left, Right, Low, High); - return Chunked_Slice (Source, Low, High, - Source.Chunk_Size, Source.Allocation_Unit); - end Trim; - - - - procedure Trim (Source : in out Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set) - is - Low : Positive; - High : Natural; - begin - Trim_Bounds (Source, Left, Right, Low, High); - if Low > 1 then - Move (Data => Source.Data.all, - Target_Position => 1, - Source_Position => Low, - Length => High - Low + 1, - Chunk_Size => Source.Chunk_Size); - end if; - Source.Size := High - Low + 1; - end Trim; - - - - function Head (Source : in Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space; - Chunk_Size : in Natural := 0; -- use value from Source - Allocation_Unit : in Natural := 0) -- use value from Source - return Chunked_String - is - Real_Chunk_Size : Positive := Default_Chunk_Size; - Real_Unit : Positive := Default_Allocation_Unit; - Data : Chunk_Array_Access := null; - begin - if Chunk_Size > 0 then - Real_Chunk_Size := Chunk_Size; - end if; - if Allocation_Unit > 0 then - Real_Unit := Allocation_Unit; - end if; - - if Count > 0 then - Resize_Chunks (Data, Count, Real_Chunk_Size, Real_Unit); - if Count > Source.Size then - Move (Data.all, 1, Source.Data.all, 1, Source.Size); - Fill (Data.all, Source.Size + 1, - Count - Source.Size, Pad, Real_Chunk_Size); - else - Move (Data.all, 1, Source.Data.all, 1, Count); - end if; - end if; - - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Real_Chunk_Size, - Allocation_Unit => Real_Unit, - Size => Count, - Data => Data); - end Head; - - - - procedure Head (Source : in out Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space) is - begin - if Count > Source.Size then - Resize_Chunks (Source.Data, Count, - Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - Fill (Source.Data.all, Source.Size + 1, Count - Source.Size, Pad, - Source.Chunk_Size); - end if; - Source.Size := Count; - end Head; - - - - function Tail (Source : in Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space; - Chunk_Size : in Natural := 0; -- use value from Source - Allocation_Unit : in Natural := 0) -- use value from Source - return Chunked_String - is - Real_Chunk_Size : Positive := Default_Chunk_Size; - Real_Unit : Positive := Default_Allocation_Unit; - Data : Chunk_Array_Access := null; - begin - if Chunk_Size > 0 then - Real_Chunk_Size := Chunk_Size; - end if; - if Allocation_Unit > 0 then - Real_Unit := Allocation_Unit; - end if; - - if Count > 0 then - Resize_Chunks (Data, Count, Real_Chunk_Size, Real_Unit); - if Count > Source.Size then - Fill (Data.all, 1, Count - Source.Size, Pad, Real_Chunk_Size); - Move (Data.all, Count - Source.Size + 1, - Source.Data.all, 1, Source.Size); - else - Move (Data.all, 1, - Source.Data.all, Source.Size - Count + 1, Count); - end if; - end if; - - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Real_Chunk_Size, - Allocation_Unit => Real_Unit, - Size => Count, - Data => Data); - end Tail; - - - - procedure Tail (Source : in out Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space) is - begin - Resize_Chunks (Source.Data, Count, - Source.Chunk_Size, Source.Allocation_Unit, - Can_Shrink => False); - if Count > Source.Size then - if Source.Size > 0 then - Move (Data => Source.Data.all, - Target_Position => Count - Source.Size + 1, - Source_Position => 1, - Length => Source.Size, - Chunk_Size => Source.Chunk_Size); - end if; - Fill (Source.Data.all, 1, Count - Source.Size, Pad, - Source.Chunk_Size); - elsif Count > 0 then - Move (Data => Source.Data.all, - Target_Position => 1, - Source_Position => Source.Size - Count + 1, - Length => Count, - Chunk_Size => Source.Chunk_Size); - end if; - Source.Size := Count; - end Tail; - - - - function "*" (Left : in Natural; - Right : in Character) - return Chunked_String - is - Chunk_Size : constant Positive := Default_Chunk_Size; - Allocation_Unit : constant Positive := Default_Allocation_Unit; - Size : constant Natural := Left; - Chunk_Nb : constant Natural - := Chunks_For (Size, Chunk_Size, Allocation_Unit); - Last_Chunk_Size : constant Natural - := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; - Data : Chunk_Array_Access := null; - begin - if Size > 0 then - Data := new Chunk_Array (1 .. Chunk_Nb); - for J in 1 .. Chunk_Nb - 1 loop - Data (J) := new String'(Ada.Strings.Fixed."*" (Chunk_Size, Right)); - end loop; - Data (Chunk_Nb) := new - String'(Ada.Strings.Fixed."*" (Last_Chunk_Size, Right)); - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Size, - Data => Data); - end "*"; - - - - function "*" (Left : in Natural; - Right : in String) - return Chunked_String - is - Chunk_Size : constant Positive := Default_Chunk_Size; - Allocation_Unit : constant Positive := Default_Allocation_Unit; - Size : constant Natural := Left * Right'Length; - Chunk_Nb : constant Natural - := Chunks_For (Size, Chunk_Size, Allocation_Unit); - Last_Chunk_Size : constant Natural - := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; - Data : Chunk_Array_Access := null; - begin - if Size > 0 then - if Chunk_Size mod Right'Length = 0 then - Data := new Chunk_Array (1 .. Chunk_Nb); - for J in 1 .. Chunk_Nb - 1 loop - Data (J) := new String'(Ada.Strings.Fixed."*" - (Chunk_Size / Right'Length, Right)); - end loop; - Data (Chunk_Nb) := new String'(Ada.Strings.Fixed."*" - (Last_Chunk_Size / Right'Length, Right)); - else - Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); - for J in 1 .. Left loop - Move (Data.all, Right, (J - 1) * Right'Length + 1, Chunk_Size); - end loop; - end if; - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Size, - Data => Data); - end "*"; - - - - function "*" (Left : in Natural; - Right : in Chunked_String) - return Chunked_String - is - Chunk_Size : constant Positive := Default_Chunk_Size; - Allocation_Unit : constant Positive := Default_Allocation_Unit; - Size : constant Natural := Left * Right.Size; - Data : Chunk_Array_Access := null; - begin - if Size > 0 then - Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); - for J in 1 .. Left loop - Move (Data.all, (J - 1) * Right.Size + 1, - Right.Data.all, 1, Right.Size); - end loop; - end if; - return Chunked_String'(Ada.Finalization.Controlled with - Chunk_Size => Chunk_Size, - Allocation_Unit => Allocation_Unit, - Size => Size, - Data => Data); - end "*"; - - - - -- Controlled object methods - - overriding procedure Initialize (Object : in out Chunked_String) is - begin - Object.Size := 0; - Object.Data := null; - end Initialize; - - - - overriding procedure Adjust (Object : in out Chunked_String) is - New_Data : Chunk_Array_Access; - begin - if Object.Data /= null then - New_Data := new Chunk_Array (Object.Data'Range); - for J in Object.Data'Range loop - New_Data (J) := new String'(Object.Data (J).all); - end loop; - Object.Data := New_Data; - end if; - end Adjust; - - - - overriding procedure Finalize (Object : in out Chunked_String) is - begin - Free (Object.Data); - end Finalize; - -end Natools.Chunked_Strings; DELETED natools-chunked_strings.ads Index: natools-chunked_strings.ads ================================================================== --- natools-chunked_strings.ads +++ natools-chunked_strings.ads @@ -1,433 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Chunked_Strings is a string container designed for large amount -- --- of data and efficient accumulation (append). Most subprograms are the -- --- direct copy of Unbounded_String equivalent from LRM, with the same -- --- semantics. -- --- -- --- The implementation uses fixed-size "chunks" of memory, so that large -- --- strings do not have to be stored in a contiguous space. This also allows -- --- more efficient appends, since only the last chunk might need dynamic -- --- resize. -- --- Moreover the last chunk is constrained to have a size multiple of -- --- Allocation_Unit, so if Allocation_Unit = Chunk_Size, no string resize -- --- ever happen. -- --- -- --- The list of chunks is stored as a usual dynamic array, so append -- --- operations are still linear (when a new chunk has to be created), they -- --- are just O(Size / Chunk_Size) instead of O(Size). For suitable values of -- --- Chunk_Size, that should be a significant improuvement. -- --- -- --- Chunk_Size and Allocation_Unit are defined per Chunked_String, which -- --- allows to use suitable parameters depending on the expected string size. -- --- Generic parameters control the default values, e.g. in operations like -- --- "&" which don't allow to specify them. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Maps; -with Natools.Accumulators; - -private with Ada.Finalization; - -generic - Default_Allocation_Unit : Positive := 64; - Default_Chunk_Size : Positive := 4096; - -package Natools.Chunked_Strings is - pragma Preelaborate (Chunked_Strings); - - package Maps renames Ada.Strings.Maps; - - type Chunked_String is new Natools.Accumulators.String_Accumulator - with private; - - function Build (Depth : Positive) - return Natools.Accumulators.String_Accumulator'Class; - -- Returns a new empty chunked string - -- Ignores its Depth argument - -- Can be used with Natools.Accumulators.String_Accumulator_Linked_Lists - - function Duplicate (Source : in Chunked_String) return Chunked_String; - -- returns a copy of the given chunked string - - procedure Free_Extra_Memory (From : in out Chunked_String); - -- Release as much memory as possible without altering the contents - - procedure Hard_Reset (Str : in out Chunked_String); - -- Empty the string and free all possible memory - - procedure Preallocate (Str : in out Chunked_String; Size : Natural); - -- Allocate enough memory to reach Size without subsequent reallocation - - procedure Soft_Reset (Str : in out Chunked_String); - -- Empty the string for reuse - - procedure To_String (Source : Chunked_String; Output : out String); - -- Write the contents of the chunked string into the output string, - -- which must be large enough. - - - ------------------------------------------- - -- String_Accumulator specific interface -- - ------------------------------------------- - - -- Append, Length and To_String are part of the standard interface - -- Hard_Reset and Soft_Reset are already in the specific interface - - function Tail (Source : in Chunked_String; Size : in Natural) return String; - - procedure Unappend (From : in out Chunked_String; Text : in String); - - - ------------------------ - -- Standard interface -- - ------------------------ - - -- All the following declarations are copied from Unbounded_String - -- interface and have exactly the same semantics. - -- Subprogram that create new Chunked_String objects also have - -- Chunk_Size and Allocation_Unit optional parameters. - - Null_Chunked_String : constant Chunked_String; - - function Length (Source : in Chunked_String) return Natural; - - type String_Access is access all String; - procedure Free (X : in out String_Access); - - -- Conversion, Concatenation, and Selection functions - - function To_Chunked_String - (Source : in String; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String; - - function To_Chunked_String - (Length : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String; - - function To_String (Source : in Chunked_String) return String; - - procedure Set_Chunked_String - (Target : out Chunked_String; - Source : in String; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit); - - procedure Append (Source : in out Chunked_String; - New_Item : in Chunked_String); - - procedure Append (Source : in out Chunked_String; - New_Item : in String); - - procedure Append (Source : in out Chunked_String; - New_Item : in Character); - - function "&" (Left, Right : in Chunked_String) - return Chunked_String; - - function "&" (Left : in Chunked_String; Right : in String) - return Chunked_String; - - function "&" (Left : in String; Right : in Chunked_String) - return Chunked_String; - - function "&" (Left : in Chunked_String; Right : in Character) - return Chunked_String; - - function "&" (Left : in Character; Right : in Chunked_String) - return Chunked_String; - - function Element (Source : in Chunked_String; - Index : in Positive) - return Character; - pragma Inline (Element); - - procedure Replace_Element (Source : in out Chunked_String; - Index : in Positive; - By : in Character); - - function Slice (Source : in Chunked_String; - Low : in Positive; - High : in Natural) - return String; - - function Chunked_Slice - (Source : in Chunked_String; - Low : in Positive; - High : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit) - return Chunked_String; - - procedure Chunked_Slice - (Source : in Chunked_String; - Target : out Chunked_String; - Low : in Positive; - High : in Natural; - Chunk_Size : in Positive := Default_Chunk_Size; - Allocation_Unit : in Positive := Default_Allocation_Unit); - - function "=" (Left, Right : in Chunked_String) return Boolean; - - function "=" (Left : in Chunked_String; Right : in String) - return Boolean; - - function "=" (Left : in String; Right : in Chunked_String) - return Boolean; - - function "<" (Left, Right : in Chunked_String) return Boolean; - - function "<" (Left : in Chunked_String; Right : in String) - return Boolean; - - function "<" (Left : in String; Right : in Chunked_String) - return Boolean; - - function "<=" (Left, Right : in Chunked_String) return Boolean; - - function "<=" (Left : in Chunked_String; Right : in String) - return Boolean; - - function "<=" (Left : in String; Right : in Chunked_String) - return Boolean; - - function ">" (Left, Right : in Chunked_String) return Boolean; - - function ">" (Left : in Chunked_String; Right : in String) - return Boolean; - - function ">" (Left : in String; Right : in Chunked_String) - return Boolean; - - function ">=" (Left, Right : in Chunked_String) return Boolean; - - function ">=" (Left : in Chunked_String; Right : in String) - return Boolean; - - function ">=" (Left : in String; Right : in Chunked_String) - return Boolean; - - function Index (Source : in Chunked_String; - Pattern : in String; - From : in Positive; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural; - - function Index (Source : in Chunked_String; - Pattern : in String; - From : in Positive; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping_Function) - return Natural; - - function Index (Source : in Chunked_String; - Pattern : in String; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural; - - function Index (Source : in Chunked_String; - Pattern : in String; - Going : in Ada.Strings.Direction := Ada.Strings.Forward; - Mapping : in Maps.Character_Mapping_Function) - return Natural; - - function Index (Source : in Chunked_String; - Set : in Maps.Character_Set; - From : in Positive; - Test : in Ada.Strings.Membership := Ada.Strings.Inside; - Going : in Ada.Strings.Direction := Ada.Strings.Forward) - return Natural; - - function Index (Source : in Chunked_String; - Set : in Maps.Character_Set; - Test : in Ada.Strings.Membership := Ada.Strings.Inside; - Going : in Ada.Strings.Direction := Ada.Strings.Forward) - return Natural; - - function Index_Non_Blank (Source : in Chunked_String; - From : in Positive; - Going : in Ada.Strings.Direction - := Ada.Strings.Forward) - return Natural; - - function Index_Non_Blank (Source : in Chunked_String; - Going : in Ada.Strings.Direction - := Ada.Strings.Forward) - return Natural; - - function Count (Source : in Chunked_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping := Maps.Identity) - return Natural; - - function Count (Source : in Chunked_String; - Pattern : in String; - Mapping : in Maps.Character_Mapping_Function) - return Natural; - - function Count (Source : in Chunked_String; - Set : in Maps.Character_Set) - return Natural; - - procedure Find_Token (Source : in Chunked_String; - Set : in Maps.Character_Set; - Test : in Ada.Strings.Membership; - First : out Positive; - Last : out Natural); - - -- String translation subprograms - - function Translate (Source : in Chunked_String; - Mapping : in Maps.Character_Mapping) - return Chunked_String; - - procedure Translate (Source : in out Chunked_String; - Mapping : in Maps.Character_Mapping); - - function Translate (Source : in Chunked_String; - Mapping : in Maps.Character_Mapping_Function) - return Chunked_String; - - procedure Translate (Source : in out Chunked_String; - Mapping : in Maps.Character_Mapping_Function); - - -- String transformation subprograms - - function Replace_Slice (Source : in Chunked_String; - Low : in Positive; - High : in Natural; - By : in String) - return Chunked_String; - - procedure Replace_Slice (Source : in out Chunked_String; - Low : in Positive; - High : in Natural; - By : in String); - - function Insert (Source : in Chunked_String; - Before : in Positive; - New_Item : in String) - return Chunked_String; - - procedure Insert (Source : in out Chunked_String; - Before : in Positive; - New_Item : in String); - - function Overwrite (Source : in Chunked_String; - Position : in Positive; - New_Item : in String) - return Chunked_String; - - procedure Overwrite (Source : in out Chunked_String; - Position : in Positive; - New_Item : in String); - - function Delete (Source : in Chunked_String; - From : in Positive; - Through : in Natural) - return Chunked_String; - - procedure Delete (Source : in out Chunked_String; - From : in Positive; - Through : in Natural); - - function Trim (Source : in Chunked_String; - Side : in Ada.Strings.Trim_End) - return Chunked_String; - - procedure Trim (Source : in out Chunked_String; - Side : in Ada.Strings.Trim_End); - - function Trim (Source : in Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set) - return Chunked_String; - - procedure Trim (Source : in out Chunked_String; - Left : in Maps.Character_Set; - Right : in Maps.Character_Set); - - function Head (Source : in Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space; - Chunk_Size : in Natural := 0; -- use value from Source - Allocation_Unit : in Natural := 0) -- use value from Source - return Chunked_String; - - procedure Head (Source : in out Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space); - - function Tail (Source : in Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space; - Chunk_Size : in Natural := 0; -- use value from Source - Allocation_Unit : in Natural := 0) -- use value from Source - return Chunked_String; - - procedure Tail (Source : in out Chunked_String; - Count : in Natural; - Pad : in Character := Ada.Strings.Space); - - function "*" (Left : in Natural; - Right : in Character) - return Chunked_String; - - function "*" (Left : in Natural; - Right : in String) - return Chunked_String; - - function "*" (Left : in Natural; - Right : in Chunked_String) - return Chunked_String; - -private - type Chunk_Array is array (Positive range <>) of String_Access; - type Chunk_Array_Access is access all Chunk_Array; - - type Chunked_String is new Ada.Finalization.Controlled - and Natools.Accumulators.String_Accumulator - with record - Chunk_Size : Positive := Default_Chunk_Size; - Allocation_Unit : Positive := Default_Allocation_Unit; - Size : Natural := 0; - Data : Chunk_Array_Access := null; - end record; - - overriding procedure Initialize (Object : in out Chunked_String); - overriding procedure Adjust (Object : in out Chunked_String); - overriding procedure Finalize (Object : in out Chunked_String); - -- Controlled type methods - - function Is_Valid (Source : in Chunked_String) return Boolean; - -- Internal consistency checks - - Null_Chunked_String : constant Chunked_String := - (Ada.Finalization.Controlled with - Chunk_Size => Default_Chunk_Size, - Allocation_Unit => Default_Allocation_Unit, - Size => 0, - Data => null); - -end Natools.Chunked_Strings; DELETED natools-getopt_long.adb Index: natools-getopt_long.adb ================================================================== --- natools-getopt_long.adb +++ natools-getopt_long.adb @@ -1,670 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Maps; - -package body Natools.Getopt_Long is - - package Fixed renames Ada.Strings.Fixed; - package Maps renames Ada.Strings.Maps; - - - --------------------------- - -- Any_Name constructors -- - --------------------------- - - function To_Name (Long_Name : String) return Any_Name is - begin - return Any_Name'(Style => Long, - Size => Long_Name'Length, - Long => Long_Name); - end To_Name; - - - function To_Name (Short_Name : Character) return Any_Name is - begin - return Any_Name'(Style => Short, Size => 1, Short => Short_Name); - end To_Name; - - - function Image (Name : Any_Name) return String is - begin - case Name.Style is - when Short => return '-' & Name.Short; - when Long => return "--" & Name.Long; - end case; --- Alternate implementation: --- case Name.Style is --- when Short => return String'(1 => Name.Short); --- when Long => return '"' & Name.Long & '"'; --- end case; - end Image; - - - - ---------------------- - -- Default handlers -- - ---------------------- - - package body Handlers is - - procedure Missing_Argument - (Handler : in out Callback; - Id : Option_Id; - Name : Any_Name) - is - pragma Unreferenced (Handler); - pragma Unreferenced (Id); - begin - raise Option_Error with - "Missing argument to option " & Image (Name); - end Missing_Argument; - - - procedure Unexpected_Argument - (Handler : in out Callback; - Id : Option_Id; - Name : Any_Name; - Argument : String) - is - pragma Unreferenced (Handler); - pragma Unreferenced (Id); - begin - raise Option_Error with - "Unexpected argument """ & Argument - & """ to option " & Image (Name); - end Unexpected_Argument; - - - procedure Unknown_Option - (Handler : in out Callback; - Name : Any_Name) - is - pragma Unreferenced (Handler); - begin - raise Option_Error with "Unknown option " & Image (Name); - end Unknown_Option; - - end Handlers; - - - - ------------------------------------- - -- Simple configuration parameters -- - ------------------------------------- - - function Posixly_Correct (Config : Configuration) return Boolean is - begin - return Config.Posixly_Correct; - end Posixly_Correct; - - - procedure Posixly_Correct - (Config : in out Configuration; - To : Boolean := True) is - begin - Config.Posixly_Correct := To; - end Posixly_Correct; - - - function Long_Only (Config : Configuration) return Boolean is - begin - return Config.Long_Only; - end Long_Only; - - - procedure Use_Long_Only - (Config : in out Configuration; - Value : Boolean := True) is - begin - Config.Long_Only := Value; - end Use_Long_Only; - - - - ---------------------------- - -- Option list management -- - ---------------------------- - - procedure Add_Option - (Config : in out Configuration; - Long_Name : String; - Short_Name : Character; - Has_Arg : Argument_Requirement; - Id : Option_Id) - is - New_Option : constant Option - := (Long_Name_Length => Long_Name'Length, - Id => Id, - Has_Arg => Has_Arg, - Long_Name => Long_Name, - Short_Name => Short_Name); - begin - if Long_Name = Null_Long_Name or Short_Name = Null_Short_Name then - raise Constraint_Error; - end if; - Config.By_Long_Name.Insert (Long_Name, New_Option); - Config.By_Short_Name.Insert (Short_Name, New_Option); - end Add_Option; - - - procedure Add_Option - (Config : in out Configuration; - Long_Name : String; - Has_Arg : Argument_Requirement; - Id : Option_Id) - is - New_Option : constant Option - := (Long_Name_Length => Long_Name'Length, - Id => Id, - Has_Arg => Has_Arg, - Long_Name => Long_Name, - Short_Name => Null_Short_Name); - begin - if Long_Name = Null_Long_Name then - raise Constraint_Error; - end if; - Config.By_Long_Name.Insert (Long_Name, New_Option); - end Add_Option; - - - procedure Add_Option - (Config : in out Configuration; - Short_Name : Character; - Has_Arg : Argument_Requirement; - Id : Option_Id) - is - New_Option : constant Option - := (Long_Name_Length => 0, - Id => Id, - Has_Arg => Has_Arg, - Long_Name => Null_Long_Name, - Short_Name => Short_Name); - begin - if Short_Name = Null_Short_Name then - raise Constraint_Error; - end if; - Config.By_Short_Name.Insert (Short_Name, New_Option); - end Add_Option; - - - procedure Del_Option - (Config : in out Configuration; - Id : Option_Id) - is - Short_Name_Cursor : Short_Option_Maps.Cursor - := Config.By_Short_Name.First; - Long_Name_Cursor : Long_Option_Maps.Cursor - := Config.By_Long_Name.First; - begin - while Short_Option_Maps.Has_Element (Short_Name_Cursor) loop - declare - Next : constant Short_Option_Maps.Cursor - := Short_Option_Maps.Next (Short_Name_Cursor); - begin - if Short_Option_Maps.Element (Short_Name_Cursor).Id = Id then - Config.By_Short_Name.Delete (Short_Name_Cursor); - end if; - Short_Name_Cursor := Next; - end; - end loop; - while Long_Option_Maps.Has_Element (Long_Name_Cursor) loop - declare - Next : constant Long_Option_Maps.Cursor - := Long_Option_Maps.Next (Long_Name_Cursor); - begin - if Long_Option_Maps.Element (Long_Name_Cursor).Id = Id then - Config.By_Long_Name.Delete (Long_Name_Cursor); - end if; - Long_Name_Cursor := Next; - end; - end loop; - end Del_Option; - - - procedure Del_Option - (Config : in out Configuration; - Long_Name : String) is - begin - Config.By_Long_Name.Delete (Long_Name); - end Del_Option; - - - procedure Del_Option - (Config : in out Configuration; - Short_Name : Character) is - begin - Config.By_Short_Name.Delete (Short_Name); - end Del_Option; - - - - ---------------------------- - -- Formatting subprograms -- - ---------------------------- - - function Format_Long_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Name_Prefix : String := "--") - return String - is - Long_Name_Count : constant Natural := Get_Long_Name_Count (Config, Id); - Space_Per_Name : constant Positive - := Name_Prefix'Length + 1 + Separator'Length; - Result : String (1 .. Long_Name_Count * Space_Per_Name); - begin - if Long_Name_Count = 0 then - return ""; - end if; - for J in 1 .. Long_Name_Count loop - declare - First : constant Positive - := Result'First + (J - 1) * Space_Per_Name; - Name : constant String := Get_Long_Name (Config, Id, J); - begin - Result (First .. First + Name_Prefix'Length - 1) := Name_Prefix; - Result (First + Name_Prefix'Length .. - First + Name_Prefix'Length + Name'Length - 1) - := Name; - Result (First + Name_Prefix'Length + Name'Length .. - First + Space_Per_Name - 1) - := Separator; - end; - end loop; - return Result (1 .. Long_Name_Count * Space_Per_Name - Separator'Length); - end Format_Long_Names; - - - function Format_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Long_Name_Prefix : String := "--"; - Short_Name_Prefix : String := "-"; - Short_First : Boolean := True) - return String - is - Long_Names : constant String - := Format_Long_Names (Config, Id, Separator, Long_Name_Prefix); - Short_Names : constant String - := Format_Short_Names (Config, Id, Separator, Short_Name_Prefix); - begin - if Long_Names = "" then - return Short_Names; - elsif Short_Names = "" then - return Long_Names; - elsif Short_First then - return Short_Names & Separator & Long_Names; - else - return Long_Names & Separator & Short_Names; - end if; - end Format_Names; - - - function Format_Short_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Name_Prefix : String := "-") - return String - is - Short_Names : constant String := Get_Short_Names (Config, Id); - Space_Per_Name : constant Positive - := Name_Prefix'Length + 1 + Separator'Length; - Result : String (1 .. Short_Names'Length * Space_Per_Name); - begin - if Short_Names = "" then - return ""; - end if; - for J in Short_Names'Range loop - declare - First : constant Positive - := Result'First + (J - Short_Names'First) * Space_Per_Name; - begin - Result (First .. First + Name_Prefix'Length - 1) := Name_Prefix; - Result (First + Name_Prefix'Length) := Short_Names (J); - Result (First + Name_Prefix'Length + 1 .. - First + Space_Per_Name - 1) := Separator; - end; - end loop; - return Result (Result'First .. Result'Last - Separator'Length); - end Format_Short_Names; - - - - function Get_Long_Name - (Config : Configuration; - Id : Option_Id; - Index : Positive := 1) - return String - is - Seen : Natural := 0; - Cursor : Long_Option_Maps.Cursor := Config.By_Long_Name.First; - begin - while Long_Option_Maps.Has_Element (Cursor) loop - declare - Opt : constant Option := Long_Option_Maps.Element (Cursor); - begin - if Opt.Id = Id then - Seen := Seen + 1; - if Seen = Index then - return Opt.Long_Name; - end if; - end if; - end; - Long_Option_Maps.Next (Cursor); - end loop; - raise Constraint_Error; - end Get_Long_Name; - - - function Get_Long_Name_Count - (Config : Configuration; - Id : Option_Id) - return Natural - is - procedure Process (Key : String; Element : Option); - procedure Process (Cursor : Long_Option_Maps.Cursor); - - Result : Natural := 0; - - procedure Process (Key : String; Element : Option) is - pragma Unreferenced (Key); - begin - if Element.Id = Id then - Result := Result + 1; - end if; - end Process; - - procedure Process (Cursor : Long_Option_Maps.Cursor) is - begin - Long_Option_Maps.Query_Element (Cursor, Process'Access); - end Process; - begin - Config.By_Long_Name.Iterate (Process'Access); - return Result; - end Get_Long_Name_Count; - - - function Get_Short_Name_Count - (Config : Configuration; - Id : Option_Id) - return Natural - is - procedure Process (Key : Character; Element : Option); - procedure Process (Cursor : Short_Option_Maps.Cursor); - - Result : Natural := 0; - - procedure Process (Key : Character; Element : Option) is - pragma Unreferenced (Key); - begin - if Element.Id = Id then - Result := Result + 1; - end if; - end Process; - - procedure Process (Cursor : Short_Option_Maps.Cursor) is - begin - Short_Option_Maps.Query_Element (Cursor, Process'Access); - end Process; - begin - Config.By_Short_Name.Iterate (Process'Access); - return Result; - end Get_Short_Name_Count; - - - function Get_Short_Names - (Config : Configuration; - Id : Option_Id) - return String - is - procedure Process (Key : Character; Element : Option); - procedure Process (Cursor : Short_Option_Maps.Cursor); - - Result : String (1 .. Config.Get_Short_Name_Count (Id)); - J : Positive := Result'First; - - procedure Process (Key : Character; Element : Option) is - begin - if Element.Id = Id then - Result (J) := Key; - J := J + 1; - end if; - end Process; - - procedure Process (Cursor : Short_Option_Maps.Cursor) is - begin - Short_Option_Maps.Query_Element (Cursor, Process'Access); - end Process; - begin - Config.By_Short_Name.Iterate (Process'Access); - return Result; - end Get_Short_Names; - - - procedure Iterate - (Config : Configuration; - Process : not null access procedure (Id : Option_Id; - Long_Name : String; - Short_Name : Character; - Has_Arg : Argument_Requirement)) - is - procedure Long_Process (Key : String; Opt : Option); - procedure Long_Query (C : Long_Option_Maps.Cursor); - procedure Short_Process (Key : Character; Opt : Option); - procedure Short_Query (C : Short_Option_Maps.Cursor); - - procedure Long_Process (Key : String; Opt : Option) is - pragma Unreferenced (Key); - begin - if Opt.Short_Name = Null_Short_Name then - Process (Opt.Id, Opt.Long_Name, Opt.Short_Name, Opt.Has_Arg); - end if; - end Long_Process; - - procedure Long_Query (C : Long_Option_Maps.Cursor) is - begin - Long_Option_Maps.Query_Element (C, Long_Process'Access); - end Long_Query; - - procedure Short_Process (Key : Character; Opt : Option) is - pragma Unreferenced (Key); - begin - Process (Opt.Id, Opt.Long_Name, Opt.Short_Name, Opt.Has_Arg); - end Short_Process; - - procedure Short_Query (C : Short_Option_Maps.Cursor) is - begin - Short_Option_Maps.Query_Element (C, Short_Process'Access); - end Short_Query; - begin - Config.By_Short_Name.Iterate (Short_Query'Access); - Config.By_Long_Name.Iterate (Long_Query'Access); - end Iterate; - - - - ----------------------------- - -- Command-line processing -- - ----------------------------- - - procedure Process - (Config : Configuration; - Handler : in out Handlers.Callback'Class; - Argument_Count : not null access function return Natural - := Ada.Command_Line.Argument_Count'Access; - Argument : not null access function (Number : Positive) return String - := Ada.Command_Line.Argument'Access) - is - procedure Process_Long_Option (Arg : String); - - Arg_Count : constant Natural := Argument_Count.all; - Arg_N : Positive := 1; - - procedure Process_Long_Option (Arg : String) is - function Has_Prefix (C : Long_Option_Maps.Cursor; Prefix : String) - return Boolean; - - Equal : constant Natural := Fixed.Index (Arg, Maps.To_Set ('=')); - Cursor : Long_Option_Maps.Cursor; - Arg_Name_Last : Natural := Arg'Last; - - function Has_Prefix (C : Long_Option_Maps.Cursor; Prefix : String) - return Boolean - is - Key : constant String := Long_Option_Maps.Key (C); - begin - return Key'Length >= Prefix'Length and then - Key (1 .. Prefix'Length) = Prefix; - end Has_Prefix; - begin - if Equal /= 0 then - Arg_Name_Last := Equal - 1; - end if; - declare - Arg_Name : String renames Arg (Arg'First .. Arg_Name_Last); - begin - -- Looking for an exact match - Cursor := Config.By_Long_Name.Find (Arg_Name); - if not Long_Option_Maps.Has_Element (Cursor) then - -- Looking for a unique partial match - Cursor := Config.By_Long_Name.Ceiling (Arg_Name); - if not Long_Option_Maps.Has_Element (Cursor) or else - not Has_Prefix (Cursor, Arg_Name) or else - Has_Prefix (Long_Option_Maps.Next (Cursor), Arg_Name) - then - Handler.Unknown_Option (To_Name (Arg_Name)); - return; - end if; - end if; - -- At this point, Cursor points to the selected argument - declare - Opt : constant Option := Long_Option_Maps.Element (Cursor); - begin - case Opt.Has_Arg is - when No_Argument => - if Equal = 0 then - Handler.Option (Opt.Id, ""); - else - Handler.Unexpected_Argument - (Opt.Id, - To_Name (Opt.Long_Name), - Arg (Equal + 1 .. Arg'Last)); - end if; - when Optional_Argument => - if Equal = 0 then - Handler.Option (Opt.Id, ""); - else - Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); - end if; - when Required_Argument => - if Equal = 0 then - if Arg_N = Arg_Count then - Handler.Missing_Argument - (Opt.Id, To_Name (Opt.Long_Name)); - else - Handler.Option (Opt.Id, Argument (Arg_N + 1)); - Arg_N := Arg_N + 1; - end if; - else - Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); - end if; - end case; - end; - end; - end Process_Long_Option; - begin - while Arg_N <= Arg_Count loop - declare - Arg : constant String := Argument (Arg_N); - begin - if Arg'Length <= 1 or else Arg (Arg'First) /= '-' then - -- This is a non-flag argument, abort option processing if - -- posixly correct. - if Config.Posixly_Correct then - exit; - else - Handler.Argument (Arg); - Arg_N := Arg_N + 1; - end if; - elsif Arg (Arg'First + 1) = '-' then - -- "--" stops option processing. - if Arg'Length = 2 then - Arg_N := Arg_N + 1; - exit; - end if; - -- Argument starting with "--": long option. - Process_Long_Option (Arg (Arg'First + 2 .. Arg'Last)); - Arg_N := Arg_N + 1; - elsif Config.Long_Only then - -- Force long option on a single dash prefix. - Process_Long_Option (Arg (Arg'First + 1 .. Arg'Last)); - Arg_N := Arg_N + 1; - else - -- Process a list of short options, until one with required - -- argument is encountered (and the rest is its argument). - for Arg_I in Arg'First + 1 .. Arg'Last loop - declare - Cursor : constant Short_Option_Maps.Cursor - := Config.By_Short_Name.Find (Arg (Arg_I)); - begin - if Short_Option_Maps.Has_Element (Cursor) then - declare - Opt : constant Option - := Short_Option_Maps.Element (Cursor); - begin - if Opt.Has_Arg = Required_Argument then - if Arg_I = Arg'Last then - if Arg_N = Arg_Count then - Handler.Missing_Argument - (Opt.Id, To_Name (Opt.Short_Name)); - else - Handler.Option - (Opt.Id, Argument (Arg_N + 1)); - Arg_N := Arg_N + 1; - exit; - end if; - else - Handler.Option - (Opt.Id, Arg (Arg_I + 1 .. Arg'Last)); - exit; - end if; - else - Handler.Option (Opt.Id, ""); - end if; - end; - else - Handler.Unknown_Option (To_Name (Arg (Arg_I))); - end if; - end; - end loop; - Arg_N := Arg_N + 1; - end if; - end; - end loop; - - -- Only non-flag arguments remain - while Arg_N <= Arg_Count loop - Handler.Argument (Argument (Arg_N)); - Arg_N := Arg_N + 1; - end loop; - end Process; - -end Natools.Getopt_Long; DELETED natools-getopt_long.ads Index: natools-getopt_long.ads ================================================================== --- natools-getopt_long.ads +++ natools-getopt_long.ads @@ -1,294 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Getopt_Long is a native Ada implementation of getopt_long() -- --- processor for command line arguments. -- --- -- --- This package is generic, and its only formal parameter is a descrete -- --- type supposed to cover all command-line options. -- --- -- --- Configuration objects hold the list of recognized options and parameters -- --- about how to process them. Options can have a single-character short -- --- name or a multiple-character long name. Moreover, there is no limit to -- --- the number of flag names referring to the same Option_Id value. -- --- -- --- Once the Configuration object has been filled with flags recognized -- --- by the client, the actual command-line arguments can be processed, -- --- using the handler callbacks from a Handlers.Callback'Class object. -- --- -- --- Callback subprograms for normal operation are Option, for command-line -- --- flags identified by their Option_Id, and Argument, for top-level command -- --- line arguments. There are also callbacks for error conditions (missing -- --- or unexpected argument, unknown option), whose implementation in -- --- Handlers.Callback are simply to raise Option_Error with an appropriate -- --- message. -- ------------------------------------------------------------------------------- - - -with Ada.Command_Line; -private with Ada.Containers.Indefinite_Ordered_Maps; - -generic - type Option_Id is (<>); - -package Natools.Getopt_Long is - pragma Preelaborate (Getopt_Long); - - Null_Long_Name : constant String := ""; - Null_Short_Name : constant Character := Character'Val (0); - - - - ------------------------------------------ - -- Holder for both short and long names -- - ------------------------------------------ - - type Name_Style is (Long, Short); - - type Any_Name (Style : Name_Style; Size : Positive) is record - case Style is - when Short => - Short : Character; - when Long => - Long : String (1 .. Size); - end case; - end record; - - function To_Name (Long_Name : String) return Any_Name; - function To_Name (Short_Name : Character) return Any_Name; - function Image (Name : Any_Name) return String; - - - - ------------------------ - -- Callback interface -- - ------------------------ - - Option_Error : exception; - - package Handlers is - - type Callback is abstract tagged null record; - - procedure Option - (Handler : in out Callback; - Id : Option_Id; - Argument : String) - is abstract; - -- Callback for successfully-parsed options. - - procedure Argument - (Handler : in out Callback; - Argument : String) - is abstract; - -- Callback for non-flag arguments. - - procedure Missing_Argument - (Handler : in out Callback; - Id : Option_Id; - Name : Any_Name); - -- Raise Option_Error (default error handler). - - procedure Unexpected_Argument - (Handler : in out Callback; - Id : Option_Id; - Name : Any_Name; - Argument : String); - -- Raise Option_Error (default error handler). - - procedure Unknown_Option - (Handler : in out Callback; - Name : Any_Name); - -- Raise Option_Error (default error handler). - - end Handlers; - - - - ---------------------------- - -- Configuration database -- - ---------------------------- - - type Argument_Requirement is - (No_Argument, Required_Argument, Optional_Argument); - - type Configuration is tagged private; - - - -- Simple parameters -- - - function Posixly_Correct (Config : Configuration) return Boolean; - - procedure Posixly_Correct - (Config : in out Configuration; - To : Boolean := True); - - function Long_Only (Config : Configuration) return Boolean; - - procedure Use_Long_Only - (Config : in out Configuration; - Value : Boolean := True); - - - -- Option list management -- - - procedure Add_Option - (Config : in out Configuration; - Long_Name : String; - Short_Name : Character; - Has_Arg : Argument_Requirement; - Id : Option_Id); - -- Add an option with both a short and a long name to the database. - - procedure Add_Option - (Config : in out Configuration; - Long_Name : String; - Has_Arg : Argument_Requirement; - Id : Option_Id); - -- Add an option with only a long name to the database. - - procedure Add_Option - (Config : in out Configuration; - Short_Name : Character; - Has_Arg : Argument_Requirement; - Id : Option_Id); - -- Add an option with only a short name to the database. - - procedure Del_Option - (Config : in out Configuration; - Id : Option_Id); - -- Remove from the database an option identified by its id. - - procedure Del_Option - (Config : in out Configuration; - Long_Name : String); - -- Remove from the database an option identified by its long name. - - procedure Del_Option - (Config : in out Configuration; - Short_Name : Character); - -- Remove from the database an option identified by its short name. - - - -- Formatting subprograms -- - - function Format_Long_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Name_Prefix : String := "--") - return String; - -- Return a human-readable list of long names for the given option. - - function Format_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Long_Name_Prefix : String := "--"; - Short_Name_Prefix : String := "-"; - Short_First : Boolean := True) - return String; - -- Return a human-readable list of all names for the given option. - - function Format_Short_Names - (Config : Configuration; - Id : Option_Id; - Separator : String := ", "; - Name_Prefix : String := "-") - return String; - -- Return a human-readable list of short names for the given option. - - function Get_Long_Name - (Config : Configuration; - Id : Option_Id; - Index : Positive := 1) - return String; - -- Return the "Index"th long name for the given option id. - -- Raise Constraint_Error when Index is not - -- in range 1 .. Get_Long_Name_Count (Config, Id) - - function Get_Long_Name_Count - (Config : Configuration; - Id : Option_Id) - return Natural; - -- Return the number of long names for the given option id. - - function Get_Short_Name_Count - (Config : Configuration; - Id : Option_Id) - return Natural; - -- Return the number of short names for the given option id. - - function Get_Short_Names - (Config : Configuration; - Id : Option_Id) - return String; - -- Return a string containing the characters for short names for - -- the given option id. - - procedure Iterate - (Config : Configuration; - Process : not null access procedure (Id : Option_Id; - Long_Name : String; - Short_Name : Character; - Has_Arg : Argument_Requirement)); - -- Iterate over all options, starting with options having a short name, - -- followed by options having only a long name, sorted respectively by - -- short and long name. - -- Process is called for each option; for options lacking a long name, - -- Long_Name is "", and for options lacking a short name, Short_Name - -- is Character'Val (0). - - - - -------------------------------------- - -- Command line argument processing -- - -------------------------------------- - - procedure Process - (Config : Configuration; - Handler : in out Handlers.Callback'Class; - Argument_Count : not null access function return Natural - := Ada.Command_Line.Argument_Count'Access; - Argument : not null access function (Number : Positive) return String - := Ada.Command_Line.Argument'Access); - -- Process system command line argument list, using the provided option - -- definitions and handler callbacks. - -private - - type Option (Long_Name_Length : Natural) is record - Id : Option_Id; - Has_Arg : Argument_Requirement; - Long_Name : String (1 .. Long_Name_Length); - Short_Name : Character; - end record; - - package Long_Option_Maps is - new Ada.Containers.Indefinite_Ordered_Maps (String, Option); - - package Short_Option_Maps is - new Ada.Containers.Indefinite_Ordered_Maps (Character, Option); - - type Configuration is tagged record - By_Long_Name : Long_Option_Maps.Map; - By_Short_Name : Short_Option_Maps.Map; - Posixly_Correct : Boolean := True; - Long_Only : Boolean := False; - end record; - -end Natools.Getopt_Long; DELETED natools-getopt_long_tests.adb Index: natools-getopt_long_tests.adb ================================================================== --- natools-getopt_long_tests.adb +++ natools-getopt_long_tests.adb @@ -1,835 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Indefinite_Vectors; -with Ada.Exceptions; -with Ada.Strings.Unbounded; -with Natools.Getopt_Long; - -package body Natools.Getopt_Long_Tests is - - package US renames Ada.Strings.Unbounded; - - ---------------------------------------- - -- Dynamic command line argument list -- - ---------------------------------------- - - package String_Vectors is new Ada.Containers.Indefinite_Vectors - (Index_Type => Positive, Element_Type => String); - - Command_Line : String_Vectors.Vector; - - - function Argument_Count return Natural; - function Argument (Number : Positive) return String; - - - function Argument_Count return Natural is - begin - return Natural (Command_Line.Length); - end Argument_Count; - - function Argument (Number : Positive) return String is - begin - return Command_Line.Element (Number); - end Argument; - - - - -------------------------------- - -- Arguments used for testing -- - -------------------------------- - - type Option_Id is - (Short_No_Arg, Short_No_Arg_2, Short_Opt_Arg, Short_Arg, - Long_No_Arg, Long_Opt_Arg, Long_Arg, Long_Ambiguous, - Mixed_No_Arg, Mixed_Opt_Arg, Mixed_Arg, - Command_Argument); - - type Flag_Seen_Array is array (Option_Id) of Boolean; - - type Flag_Argument_Array is array (Option_Id) of US.Unbounded_String; - - Separator : constant Character := ';'; - - package Getopt is new Natools.Getopt_Long (Option_Id); - - function Getopt_Config - (Posixly_Correct, Long_Only : Boolean) - return Getopt.Configuration; - -- Create the Getopt.Configuration object used for these tests. - - - function Getopt_Config - (Posixly_Correct, Long_Only : Boolean) - return Getopt.Configuration is - begin - return OD : Getopt.Configuration do - OD.Add_Option ('a', Getopt.No_Argument, Short_No_Arg); - OD.Add_Option ('q', Getopt.No_Argument, Short_No_Arg_2); - OD.Add_Option ('f', Getopt.Required_Argument, Short_Arg); - OD.Add_Option ('v', Getopt.Optional_Argument, Short_Opt_Arg); - OD.Add_Option ("aq", Getopt.No_Argument, Long_Ambiguous); - OD.Add_Option ("aquatic", Getopt.No_Argument, Long_No_Arg); - OD.Add_Option ("color", Getopt.Optional_Argument, Long_Opt_Arg); - OD.Add_Option ("input", Getopt.Required_Argument, Long_Arg); - OD.Add_Option ("execute", 'e', Getopt.Required_Argument, Mixed_Arg); - OD.Add_Option ("ignore-case", 'i', Getopt.No_Argument, Mixed_No_Arg); - OD.Add_Option ("write", 'w', Getopt.Optional_Argument, Mixed_Opt_Arg); - OD.Posixly_Correct (Posixly_Correct); - OD.Use_Long_Only (Long_Only); - end return; - end Getopt_Config; - - - - ------------------- - -- Test Handlers -- - ------------------- - - package Handlers is - - type Basic is new Getopt.Handlers.Callback with record - Flag_Seen : Flag_Seen_Array := (others => False); - Flag_Argument : Flag_Argument_Array; - Flag_Error : String_Vectors.Vector; - end record; - - overriding - procedure Option (Handler : in out Basic; - Id : Option_Id; - Argument : String); - -- Process the given option, by recording it as seen in Flag_Seen - -- and appending the argument to Flag_Argument. - - overriding - procedure Argument (Handler : in out Basic; - Argument : String); - -- Process the given argument, by recording it - -- in Flag_Seen (Command_Argument) and appending it - -- to Flag_Argument (Command_Argument). - - not overriding - procedure Dump (Handler : Basic; - Report : in out NT.Reporter'Class); - -- Dump the current state (Flag_* variables) into the Report. - - - type Error_Count is record - Missing_Argument_Long : Natural := 0; - Missing_Argument_Short : Natural := 0; - Unexpected_Argument : Natural := 0; - Unknown_Long_Option : Natural := 0; - Unknown_Short_Option : Natural := 0; - end record; - - type Recovering is new Basic with record - Count : Error_Count; - end record; - - procedure Increment (Number : in out Natural); - - overriding - procedure Missing_Argument - (Handler : in out Recovering; - Id : Option_Id; - Name : Getopt.Any_Name); - - overriding - procedure Unexpected_Argument - (Handler : in out Recovering; - Id : Option_Id; - Name : Getopt.Any_Name; - Argument : String); - - overriding - procedure Unknown_Option - (Handler : in out Recovering; - Name : Getopt.Any_Name); - - end Handlers; - - - - package body Handlers is - - overriding - procedure Option (Handler : in out Basic; - Id : Option_Id; - Argument : String) is - begin - Handler.Flag_Seen (Id) := True; - US.Append (Handler.Flag_Argument (Id), Argument & Separator); - end Option; - - - overriding - procedure Argument (Handler : in out Basic; - Argument : String) is - begin - Option (Handler, Command_Argument, Argument); - end Argument; - - - not overriding - procedure Dump (Handler : Basic; - Report : in out NT.Reporter'Class) - is - procedure Process (Position : String_Vectors.Cursor); - function Seen_String (Seen : Boolean) return String; - - procedure Process (Position : String_Vectors.Cursor) is - begin - Report.Info ("Error """ & String_Vectors.Element (Position) & '"'); - end Process; - - function Seen_String (Seen : Boolean) return String is - begin - if Seen then - return "Seen"; - else - return "Not seen"; - end if; - end Seen_String; - begin - Report.Info ("Flags:"); - for Id in Option_Id loop - Report.Info (" " - & Option_Id'Image (Id) & ": " - & Seen_String (Handler.Flag_Seen (Id)) & ", """ - & US.To_String (Handler.Flag_Argument (Id)) & '"'); - end loop; - Handler.Flag_Error.Iterate (Process'Access); - end Dump; - - - procedure Increment (Number : in out Natural) is - begin - Number := Number + 1; - end Increment; - - - overriding - procedure Missing_Argument - (Handler : in out Recovering; - Id : Option_Id; - Name : Getopt.Any_Name) - is - pragma Unreferenced (Id); - begin - case Name.Style is - when Getopt.Short => - Increment (Handler.Count.Missing_Argument_Short); - when Getopt.Long => - Increment (Handler.Count.Missing_Argument_Long); - end case; - end Missing_Argument; - - overriding - procedure Unexpected_Argument - (Handler : in out Recovering; - Id : Option_Id; - Name : Getopt.Any_Name; - Argument : String) - is - pragma Unreferenced (Id); - pragma Unreferenced (Name); - pragma Unreferenced (Argument); - begin - Increment (Handler.Count.Unexpected_Argument); - end Unexpected_Argument; - - - overriding - procedure Unknown_Option - (Handler : in out Recovering; - Name : Getopt.Any_Name) is - begin - case Name.Style is - when Getopt.Short => - Increment (Handler.Count.Unknown_Short_Option); - when Getopt.Long => - Increment (Handler.Count.Unknown_Long_Option); - end case; - end Unknown_Option; - - end Handlers; - - - - ---------------------------- - -- Generic test procedure -- - ---------------------------- - - procedure Test - (Report : in out NT.Reporter'Class; - Name : String; - Expected_Seen : Flag_Seen_Array; - Expected_Argument : Flag_Argument_Array; - Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector; - Posixly_Correct : Boolean := True; - Long_Only : Boolean := False); - - - procedure Test - (Report : in out NT.Reporter'Class; - Name : String; - Expected_Seen : Flag_Seen_Array; - Expected_Argument : Flag_Argument_Array; - Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector; - Posixly_Correct : Boolean := True; - Long_Only : Boolean := False) - is - use type String_Vectors.Vector; - Config : constant Getopt.Configuration - := Getopt_Config (Posixly_Correct, Long_Only); - Handler : Handlers.Basic; - begin - begin - Getopt.Process - (Config => Config, - Handler => Handler, - Argument_Count => Argument_Count'Access, - Argument => Argument'Access); - exception - when Error : Getopt.Option_Error => - Handler.Flag_Error.Append - (Ada.Exceptions.Exception_Message (Error)); - end; - - if Handler.Flag_Seen = Expected_Seen and - Handler.Flag_Argument = Expected_Argument and - Handler.Flag_Error = Expected_Error - then - Report.Item (Name, NT.Success); - else - Report.Item (Name, NT.Fail); - Handler.Dump (Report); - end if; - exception - when Error : others => - Report.Report_Exception (Name, Error); - Handler.Dump (Report); - end Test; - - - - --------------------------- - -- Public test functions -- - --------------------------- - - procedure All_Tests (Report : in out NT.Reporter'Class) is - begin - Test_Arguments (Report); - Test_Empty (Report); - Test_Error_Callbacks (Report); - Test_Everything (Report); - Test_Long (Report); - Test_Long_Only (Report); - Test_Long_Partial (Report); - Test_Long_Partial_Ambiguous (Report); - Test_Missing_Argument_Long (Report); - Test_Missing_Argument_Short (Report); - Test_Mixed_Arg (Report); - Test_Mixed_No_Arg (Report); - Test_Posixly_Correct (Report); - Test_Short_Argument (Report); - Test_Short_Compact (Report); - Test_Short_Expanded (Report); - Test_Unexpected_Argument (Report); - Test_Unknown_Long (Report); - Test_Unknown_Short (Report); - end All_Tests; - - - procedure Test_Arguments (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("Argument 1"); - Command_Line.Append ("Argument 2"); - Command_Line.Append ("Argument 3"); - Test (Report, "Arguments without flag", - (Command_Argument => True, - others => False), - (Command_Argument - => US.To_Unbounded_String ("Argument 1;Argument 2;Argument 3;"), - others => US.Null_Unbounded_String)); - end Test_Arguments; - - - procedure Test_Empty (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Test (Report, "Empty command line", - (others => False), - (others => US.Null_Unbounded_String)); - end Test_Empty; - - - procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class) is - procedure Local_Test - (Name : String; - Expected_Seen : Flag_Seen_Array; - Expected_Argument : Flag_Argument_Array; - Expected_Count : Handlers.Error_Count); - - - procedure Local_Test - (Name : String; - Expected_Seen : Flag_Seen_Array; - Expected_Argument : Flag_Argument_Array; - Expected_Count : Handlers.Error_Count) - is - use type Handlers.Error_Count; - Config : constant Getopt.Configuration := Getopt_Config (True, False); - Handler : Handlers.Recovering; - begin - Getopt.Process - (Config => Config, - Handler => Handler, - Argument_Count => Argument_Count'Access, - Argument => Argument'Access); - if Handler.Count /= Expected_Count then - Report.Item (Name, NT.Fail); - if Handler.Count.Missing_Argument_Long - /= Expected_Count.Missing_Argument_Long - then - Report.Info ("Missing argument to long option callback called" - & Natural'Image (Handler.Count.Missing_Argument_Long) - & " times, expected" - & Natural'Image (Expected_Count.Missing_Argument_Long)); - end if; - if Handler.Count.Missing_Argument_Short - /= Expected_Count.Missing_Argument_Short - then - Report.Info ("Missing argument to short option callback called" - & Natural'Image (Handler.Count.Missing_Argument_Short) - & " times, expected" - & Natural'Image (Expected_Count.Missing_Argument_Short)); - end if; - if Handler.Count.Unexpected_Argument - /= Expected_Count.Unexpected_Argument - then - Report.Info ("Unexpected argument callback called" - & Natural'Image (Handler.Count.Unexpected_Argument) - & " times, expected" - & Natural'Image (Expected_Count.Unexpected_Argument)); - end if; - if Handler.Count.Unknown_Long_Option - /= Expected_Count.Unknown_Long_Option - then - Report.Info ("Unknown long option callback called" - & Natural'Image (Handler.Count.Unknown_Long_Option) - & " times, expected" - & Natural'Image (Expected_Count.Unknown_Long_Option)); - end if; - if Handler.Count.Unknown_Short_Option - /= Expected_Count.Unknown_Short_Option - then - Report.Info ("Unknown short option callback called" - & Natural'Image (Handler.Count.Unknown_Short_Option) - & " times, expected" - & Natural'Image (Expected_Count.Unknown_Short_Option)); - end if; - elsif Handler.Flag_Seen /= Expected_Seen or - Handler.Flag_Argument /= Expected_Argument - then - Report.Item (Name, NT.Fail); - Handler.Dump (Report); - else - Report.Item (Name, NT.Success); - end if; - exception - when Error : others => - Report.Report_Exception (Name, Error); - Handler.Dump (Report); - end Local_Test; - begin - Report.Section ("Error-handling callbacks"); - - Command_Line.Clear; - Command_Line.Append ("-af"); - Local_Test ("Missing argument for short option", - (Short_No_Arg => True, others => False), - (Short_No_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - (Missing_Argument_Short => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("--color"); - Command_Line.Append ("--input"); - Local_Test ("Missing argument for long option", - (Long_Opt_Arg => True, others => False), - (Long_Opt_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - (Missing_Argument_Long => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("--aquatic=extra"); - Local_Test ("Unexpected argument", - (others => False), - (others => US.Null_Unbounded_String), - (Unexpected_Argument => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("-a"); - Command_Line.Append ("--ignore-case=true"); - Command_Line.Append ("--execute"); - Command_Line.Append ("command"); - Command_Line.Append ("file"); - Local_Test ("Process continues after caught unexpected argument", - (Short_No_Arg | Mixed_Arg | Command_Argument => True, - others => False), - (Short_No_Arg => US.To_Unbounded_String (";"), - Mixed_Arg => US.To_Unbounded_String ("command;"), - Command_Argument => US.To_Unbounded_String ("file;"), - others => US.Null_Unbounded_String), - (Unexpected_Argument => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("-abqffoo"); - Local_Test ("Unknown short option", - (Short_No_Arg | Short_No_Arg_2 | Short_Arg => True, - others => False), - (Short_No_Arg => US.To_Unbounded_String (";"), - Short_No_Arg_2 => US.To_Unbounded_String (";"), - Short_Arg => US.To_Unbounded_String ("foo;"), - others => US.Null_Unbounded_String), - (Unknown_Short_Option => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("--execute"); - Command_Line.Append ("command"); - Command_Line.Append ("--unknown=argument"); - Command_Line.Append ("file"); - Local_Test ("Unknown long option", - (Mixed_Arg | Command_Argument => True, others => False), - (Mixed_Arg => US.To_Unbounded_String ("command;"), - Command_Argument => US.To_Unbounded_String ("file;"), - others => US.Null_Unbounded_String), - (Unknown_Long_Option => 1, others => 0)); - - Command_Line.Clear; - Command_Line.Append ("--ignore-case"); - Command_Line.Append ("-bffoo"); - Command_Line.Append ("--aq=unexpected"); - Command_Line.Append ("-ecommand"); - Command_Line.Append ("--unknown"); - Command_Line.Append ("--input"); - Local_Test ("All errors simultaneously", - (Short_Arg | Mixed_No_Arg | Mixed_Arg => True, - others => False), - (Short_Arg => US.To_Unbounded_String ("foo;"), - Mixed_Arg => US.To_Unbounded_String ("command;"), - Mixed_No_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - (Missing_Argument_Long => 1, - Missing_Argument_Short => 0, - Unexpected_Argument => 1, - Unknown_Long_Option => 1, - Unknown_Short_Option => 1)); - - Report.End_Section; - end Test_Error_Callbacks; - - - procedure Test_Everything (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--write=arg 1"); - Command_Line.Append ("-awvfarg 2"); - Command_Line.Append ("--aq"); - Command_Line.Append ("-e"); - Command_Line.Append ("arg 3"); - Command_Line.Append ("--ignore-case"); - Command_Line.Append ("--color=arg 4"); - Command_Line.Append ("-iv"); - Command_Line.Append ("--execute=arg 5"); - Command_Line.Append ("--color"); - Command_Line.Append ("--input"); - Command_Line.Append ("arg 6"); - Command_Line.Append ("arg 7"); - Command_Line.Append ("arg 8"); - Test (Report, "Everything together", - (Short_No_Arg_2 | Long_No_Arg => False, others => True), - (Short_No_Arg => US.To_Unbounded_String (";"), - Short_No_Arg_2 => US.Null_Unbounded_String, - Short_Arg => US.To_Unbounded_String ("arg 2;"), - Short_Opt_Arg => US.To_Unbounded_String (";;"), - Long_Ambiguous => US.To_Unbounded_String (";"), - Long_No_Arg => US.Null_Unbounded_String, - Long_Opt_Arg => US.To_Unbounded_String ("arg 4;;"), - Long_Arg => US.To_Unbounded_String ("arg 6;"), - Mixed_Arg => US.To_Unbounded_String ("arg 3;arg 5;"), - Mixed_No_Arg => US.To_Unbounded_String (";;"), - Mixed_Opt_Arg => US.To_Unbounded_String ("arg 1;;"), - Command_Argument => US.To_Unbounded_String ("arg 7;arg 8;"))); - end Test_Everything; - - - procedure Test_Long (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--aquatic"); - Command_Line.Append ("--input=i equal"); - Command_Line.Append ("--color=c equal"); - Command_Line.Append ("--input"); - Command_Line.Append ("i space"); - Command_Line.Append ("--color"); - Command_Line.Append ("c space"); - Command_Line.Append ("top level"); - Test (Report, "Long flags", - (Long_No_Arg | Long_Opt_Arg | Long_Arg | Command_Argument => True, - others => False), - (Long_No_Arg => US.To_Unbounded_String (";"), - Long_Opt_Arg => US.To_Unbounded_String ("c equal;;"), - Long_Arg => US.To_Unbounded_String ("i equal;i space;"), - Command_Argument => US.To_Unbounded_String ("c space;top level;"), - others => US.Null_Unbounded_String)); - end Test_Long; - - - procedure Test_Long_Only (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-aq"); - -- Can be either 'a' and 'q' short flags or "aq" long flag, depending - -- on Long_Only parameter - - -- Without Long_Only (default) - Test (Report, "Long_Only disabled (default)", - (Short_No_Arg | Short_No_Arg_2 => True, others => False), - (Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - Long_Only => False); - - -- With Long_Only - Test (Report, "Long_Only enabled", - (Long_Ambiguous => True, others => False), - (Long_Ambiguous => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - Long_Only => True); - end Test_Long_Only; - - - procedure Test_Long_Partial (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--aqu"); - Command_Line.Append ("--co=foo"); - Command_Line.Append ("--in"); - Command_Line.Append ("bar"); - Test (Report, "Partial matches for long flags", - (Long_No_Arg | Long_Opt_Arg | Long_Arg => True, others => False), - (Long_No_Arg => US.To_Unbounded_String (";"), - Long_Opt_Arg => US.To_Unbounded_String ("foo;"), - Long_Arg => US.To_Unbounded_String ("bar;"), - others => US.Null_Unbounded_String)); - end Test_Long_Partial; - - - procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--i"); - -- partial match for both "input" and "ignore-case" long flags - Test (Report, "Ambiguous partial match for long flags", - (others => False), - (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown option --i", 1)); - - Command_Line.Clear; - Command_Line.Append ("--aq"); - -- partial match for both "aq" and "aquatic" long flags - -- but exact match is preferred - Test (Report, "Ambiguous exact match for long flags", - (Long_Ambiguous => True, others => False), - (Long_Ambiguous => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String)); - end Test_Long_Partial_Ambiguous; - - - procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--color"); - Command_Line.Append ("--input"); - Test (Report, "Missing argument for long option", - (Long_Opt_Arg => True, others => False), - (Long_Opt_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - String_Vectors.To_Vector - ("Missing argument to option --input", 1)); - end Test_Missing_Argument_Long; - - - procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-v"); - Command_Line.Append ("-f"); - Test (Report, "Missing argument for long option", - (Short_Opt_Arg => True, others => False), - (Short_Opt_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Missing argument to option -f", 1)); - end Test_Missing_Argument_Short; - - - procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-efoo"); - Command_Line.Append ("-qe"); - Command_Line.Append ("bar"); - Command_Line.Append ("-aebaz"); - Command_Line.Append ("--execute=long"); - Test (Report, "Short and long options with arguments", - (Mixed_Arg | Short_No_Arg | Short_No_Arg_2 => True, - others => False), - (Mixed_Arg => US.To_Unbounded_String ("foo;bar;baz;long;"), - Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String)); - end Test_Mixed_Arg; - - - procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-ai"); - Command_Line.Append ("--ignore-case"); - Test (Report, "Short and long options without arguments", - (Mixed_No_Arg | Short_No_Arg => True, others => False), - (Mixed_No_Arg => US.To_Unbounded_String (";;"), - Short_No_Arg => US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String)); - end Test_Mixed_No_Arg; - - - procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-a"); - Command_Line.Append ("top level"); - Command_Line.Append ("-q"); - -- Posixly_Correct defines whether this "-q" is a top-level argument - -- or a short flag - - -- With the flag - Test (Report, "Posixly correct behavior", - (Short_No_Arg | Command_Argument => True, - others => False), - (Short_No_Arg => US.To_Unbounded_String (";"), - Command_Argument => US.To_Unbounded_String ("top level;-q;"), - others => US.Null_Unbounded_String), - Posixly_Correct => True); - - -- Without the flag - Test (Report, "GNU (posixly incorrect) behavior", - (Short_No_Arg | Short_No_Arg_2 | Command_Argument => True, - others => False), - (Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), - Command_Argument => US.To_Unbounded_String ("top level;"), - others => US.Null_Unbounded_String), - Posixly_Correct => False); - end Test_Posixly_Correct; - - - procedure Test_Short_Argument (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-faq"); - -- "aq" is argument for 'f' short flag, not 'a' and 'q' short flags - Command_Line.Append ("-f"); - Command_Line.Append ("-a"); - -- "-a" is argument for 'f' short flag, not 'a' short flag - Command_Line.Append ("-v"); - Command_Line.Append ("bar"); - -- "bar" is top level argument, because optional argument for short - -- flags are never set - Test (Report, "Arguments to short flags", - (Short_Arg | Short_Opt_Arg | Command_Argument => True, - others => False), - (Short_Arg => US.To_Unbounded_String ("aq;-a;"), - Short_Opt_Arg => US.To_Unbounded_String (";"), - Command_Argument => US.To_Unbounded_String ("bar;"), - others => US.Null_Unbounded_String)); - end Test_Short_Argument; - - - procedure Test_Short_Compact (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-avq"); - -- "q" is not argument to 'v' short flag, but a short flag itself - Test (Report, "Argumentless compact short flags", - (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True, - others => False), - (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => - US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String)); - end Test_Short_Compact; - - - procedure Test_Short_Expanded (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-a"); - Command_Line.Append ("-v"); - Command_Line.Append ("-q"); - Test (Report, "Argumentless expanded short flags", - (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True, - others => False), - (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => - US.To_Unbounded_String (";"), - others => US.Null_Unbounded_String)); - end Test_Short_Expanded; - - - procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--color=foo"); - Command_Line.Append ("--aq=bar"); - Test (Report, "Unexpected argument to long option", - (Long_Opt_Arg => True, others => False), - (Long_Opt_Arg => US.To_Unbounded_String ("foo;"), - others => US.Null_Unbounded_String), - String_Vectors.To_Vector - ("Unexpected argument ""bar"" to option --aq", 1)); - end Test_Unexpected_Argument; - - - procedure Test_Unknown_Long (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("--long-flag"); - Test (Report, "Unknown long flag", - (others => False), (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown option --long-flag", 1)); - end Test_Unknown_Long; - - - procedure Test_Unknown_Short (Report : in out NT.Reporter'Class) is - begin - Command_Line.Clear; - Command_Line.Append ("-g"); - Test (Report, "Unknown short flag", - (others => False), (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown option -g", 1)); - end Test_Unknown_Short; - -end Natools.Getopt_Long_Tests; DELETED natools-getopt_long_tests.ads Index: natools-getopt_long_tests.ads ================================================================== --- natools-getopt_long_tests.ads +++ natools-getopt_long_tests.ads @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Getopt_Long_Tests is a test suite for Natools.Getopt_Long -- --- command-line argument processing facilities. -- ------------------------------------------------------------------------------- - -with Natools.Tests; - -package Natools.Getopt_Long_Tests is - pragma Preelaborate (Getopt_Long_Tests); - - package NT renames Natools.Tests; - - procedure All_Tests (Report : in out NT.Reporter'Class); - - procedure Test_Arguments (Report : in out NT.Reporter'Class); - procedure Test_Empty (Report : in out NT.Reporter'Class); - procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class); - procedure Test_Everything (Report : in out NT.Reporter'Class); - procedure Test_Long (Report : in out NT.Reporter'Class); - procedure Test_Long_Only (Report : in out NT.Reporter'Class); - procedure Test_Long_Partial (Report : in out NT.Reporter'Class); - procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class); - procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class); - procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class); - procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class); - procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class); - procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class); - procedure Test_Short_Argument (Report : in out NT.Reporter'Class); - procedure Test_Short_Compact (Report : in out NT.Reporter'Class); - procedure Test_Short_Expanded (Report : in out NT.Reporter'Class); - procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class); - procedure Test_Unknown_Long (Report : in out NT.Reporter'Class); - procedure Test_Unknown_Short (Report : in out NT.Reporter'Class); - -end Natools.Getopt_Long_Tests; DELETED natools-tests-text_io.adb Index: natools-tests-text_io.adb ================================================================== --- natools-tests-text_io.adb +++ natools-tests-text_io.adb @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Text_IO; - -package body Natools.Tests.Text_IO is - - ------------------------ - -- Helper subprograms -- - ------------------------ - - function Indentation (Level : Natural) return String; - -- Return the indentation string for the given level. - - function Indentation (Report : Text_Reporter) return String; - -- Return the indentation string for the current level of Report. - - - function Indentation (Level : Natural) return String is - use Ada.Strings.Fixed; - begin - return Level * " "; - end Indentation; - - - function Indentation (Report : Text_Reporter) return String is - begin - return Indentation (Natural (Report.Results.Length)); - end Indentation; - - - ------------------------ - -- Public subprograms -- - ------------------------ - - procedure Section (Report : in out Text_Reporter; Name : String) is - begin - Ada.Text_IO.Put_Line (Indentation (Report) & "Section: " & Name); - Result_Lists.Append (Report.Results, (others => 0)); - end Section; - - - procedure End_Section (Report : in out Text_Reporter) is - Last_Item : Result_Lists.Cursor := Report.Results.Last; - begin - Result_Lists.Delete (Report.Results, Last_Item); - end End_Section; - - - procedure Item - (Report : in out Text_Reporter; - Name : in String; - Outcome : in Result) - is - use Ada.Strings.Fixed; - - procedure Process (Position : Result_Lists.Cursor); - procedure Update (R : in out Result_Summary); - - Indent : constant String := Indentation (Report); - Text_Size : constant Positive - := Indent'Length + Name'Length + Max_Result_String_Size + 1; - Line_Length : constant Natural - := Natural (Ada.Text_IO.Line_Length); - - procedure Process (Position : Result_Lists.Cursor) is - begin - Result_Lists.Update_Element (Report.Results, Position, Update'Access); - end Process; - - procedure Update (R : in out Result_Summary) is - begin - R (Outcome) := R (Outcome) + 1; - end Update; - begin - if Text_Size < Line_Length then - Ada.Text_IO.Put_Line (Indent & Name - & (Line_Length - Text_Size) * " " - & Result'Image (Outcome)); - else - Ada.Text_IO.Put_Line (Indent & Name); - Ada.Text_IO.Put_Line (Indent & " -> " & Result'Image (Outcome)); - end if; - Result_Lists.Iterate (Report.Results, Process'Access); - Report.Total (Outcome) := Report.Total (Outcome) + 1; - end Item; - - - procedure Info (Report : in out Text_Reporter; Text : String) is - pragma Unreferenced (Report); - begin - Ada.Text_IO.Put_Line (Text); - end Info; - - - function Current_Results (Report : Text_Reporter) return Result_Summary is - begin - return Result_Lists.Element (Report.Results.Last); - end Current_Results; - - function Total_Results (Report : Text_Reporter) return Result_Summary is - begin - return Report.Total; - end Total_Results; - - - procedure Print_Results (R : Result_Summary) is - use Ada.Strings.Fixed; - begin - for I in R'Range loop - declare - Image : constant String := Result'Image (I); - begin - Ada.Text_IO.Put_Line - (Image - & (Max_Result_String_Size + 1 - Image'Length) * " " - & Natural'Image (R (I))); - end; - end loop; - end Print_Results; -end Natools.Tests.Text_IO; DELETED natools-tests-text_io.ads Index: natools-tests-text_io.ads ================================================================== --- natools-tests-text_io.ads +++ natools-tests-text_io.ads @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Tests.Text_IO is a simple implementation of Natools.Tests -- --- interface. It immediately prints Item and Info to default output using -- --- Ada.Text_IO facilities. Current and total result summaries are stored -- --- in a stack using Doubly_Linked_Lists. -- --- Sections are represented by a two-space indentation. -- ------------------------------------------------------------------------------- - -private with Ada.Containers.Doubly_Linked_Lists; - -package Natools.Tests.Text_IO is - - type Text_Reporter is new Reporter with private; - - procedure Section (Report : in out Text_Reporter; Name : String); - -- Start a new (sub)section. This prints section header and increments - -- indentation. - - procedure End_Section (Report : in out Text_Reporter); - -- End the current (sub)section. This does not output anything, but - -- decrements the current indentation. - - procedure Item - (Report : in out Text_Reporter; - Name : in String; - Outcome : in Result); - -- Output the Item with its outcome. If Line_Length is wide enough, - -- the outcome is right-aligned on the same line as the test name, - -- otherwise it is printed below with an additional indentation. - - procedure Info (Report : in out Text_Reporter; Text : String); - -- Output the Text directly. Association with previous Item is visual. - - function Current_Results (Report : Text_Reporter) return Result_Summary; - -- Return the number of each result type in the current subsection. - - function Total_Results (Report : Text_Reporter) return Result_Summary; - -- Return the total number of each result type. - - - procedure Print_Results (R : Result_Summary); - -- Pretty-print the result summary into the default output. - -private - - package Result_Lists is - new Ada.Containers.Doubly_Linked_Lists (Result_Summary); - - type Text_Reporter is new Reporter with record - Results : Result_Lists.List; - Total : Result_Summary := (others => 0); - end record; - -end Natools.Tests.Text_IO; DELETED natools-tests.adb Index: natools-tests.adb ================================================================== --- natools-tests.adb +++ natools-tests.adb @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - - -package body Natools.Tests is - - function To_Result (Succeeded : Boolean) return Result is - begin - if Succeeded then - return Success; - else - return Fail; - end if; - end To_Result; - - - procedure Report_Exception - (Report : in out Reporter'Class; - Test_Name : String; - Ex : Ada.Exceptions.Exception_Occurrence; - Code : Result := Error) is - begin - Item (Report, Test_Name, Code); - Info (Report, - "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:"); - Info (Report, Ada.Exceptions.Exception_Message (Ex)); - end Report_Exception; - -end Natools.Tests; DELETED natools-tests.ads Index: natools-tests.ads ================================================================== --- natools-tests.ads +++ natools-tests.ads @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools.Tests is an abstract interface for objects holding the results -- --- of a series of tests. -- --- -- --- Each test can have one of the following results: -- --- * Success, when everything goes well, -- --- * Fail, when the test itself went fine the but the result is wrong, -- --- * Error, when the test itself went wrong, which does not tell whether -- --- the tested thing is fine or not, -- --- * Skipped, when for any reason the test has not been performed -- --- (e.g. missing dependency). -- --- -- --- Tests are gathered into sections, which can be nested. What a section -- --- exactly means is left to the implementation of this interface. -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; - -package Natools.Tests is - pragma Preelaborate (Tests); - - type Reporter is interface; - type Result is (Success, Fail, Error, Skipped); - type Result_Summary is array (Result) of Natural; - - procedure Section (Report : in out Reporter; Name : String) is abstract; - procedure End_Section (Report : in out Reporter) is abstract; - -- These procedures change the internal state of Report to respectively - -- enter and leave a (sub)section. - - procedure Item - (Report : in out Reporter; - Name : in String; - Outcome : in Result) - is abstract; - -- Append a new test item (with its outcome) to the current section - -- of Report. - - procedure Info (Report : in out Reporter; Text : String) is abstract; - -- Append free informational text related to the previous Item appended. - - function Current_Results (Report : Reporter) return Result_Summary - is abstract; - -- Return the number of each result type in the current section. - - function Total_Results (Report : Reporter) return Result_Summary - is abstract; - -- Return the total number of each result type in the current section. - - function To_Result (Succeeded : Boolean) return Result; - -- Return Success or Fail depending on the Boolean input. - - Max_Result_String_Size : constant Positive := 7; - -- Maximum length of any string returned by Result'Image. - - - ------------------------ - -- Helper subprograms -- - ------------------------ - - procedure Report_Exception - (Report : in out Reporter'Class; - Test_Name : String; - Ex : Ada.Exceptions.Exception_Occurrence; - Code : Result := Error); - -- Append to Report a new Item, whose result is Code, along with - -- a description of the exception Ex as Info entries. - -end Natools.Tests; DELETED natools.ads Index: natools.ads ================================================================== --- natools.ads +++ natools.ads @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Natools is a collection of miscellaneous small utilities gathered in one -- --- shared library. -- ------------------------------------------------------------------------------- - - -package Natools is - pragma Pure (Natools); - -end Natools; ADDED src/natools-accumulators-string_accumulator_linked_lists.adb Index: src/natools-accumulators-string_accumulator_linked_lists.adb ================================================================== --- src/natools-accumulators-string_accumulator_linked_lists.adb +++ src/natools-accumulators-string_accumulator_linked_lists.adb @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +package body Natools.Accumulators.String_Accumulator_Linked_Lists is + + procedure Initialize_If_Needed + (Object : in out String_Accumulator_Linked_List) is + begin + if Object.Stack.Is_Empty then + Object.Stack.Append (Object.Build (1)); + Object.Position := Object.Stack.Last; + end if; + end Initialize_If_Needed; + + + + procedure Append (To : in out String_Accumulator_Linked_List; + Text : String) + is + procedure Process (Element : in out String_Accumulator'Class); + + procedure Process (Element : in out String_Accumulator'Class) is + begin + Element.Append (Text); + end Process; + begin + Initialize_If_Needed (To); + To.Stack.Update_Element (To.Position, Process'Access); + end Append; + + + + procedure Hard_Reset (Acc : in out String_Accumulator_Linked_List) is + begin + Acc.Stack.Clear; + Acc.Position := Lists.No_Element; + end Hard_Reset; + + + + function Length (Acc : String_Accumulator_Linked_List) return Natural is + procedure Process (Element : String_Accumulator'Class); + + Result : Natural; + + procedure Process (Element : String_Accumulator'Class) is + begin + Result := Element.Length; + end Process; + begin + if Acc.Stack.Is_Empty then + return 0; + else + Lists.Query_Element (Acc.Position, Process'Access); + return Result; + end if; + end Length; + + + + procedure Push (Acc : in out String_Accumulator_Linked_List) is + procedure Process (Element : in out String_Accumulator'Class); + + use type Lists.Cursor; + + procedure Process (Element : in out String_Accumulator'Class) is + begin + Soft_Reset (Element); + end Process; + begin + Initialize_If_Needed (Acc); + Lists.Next (Acc.Position); + if Acc.Position = Lists.No_Element then + declare + Level_Created : constant Positive + := Natural (Acc.Stack.Length) + 1; + begin + Acc.Stack.Append (Acc.Build (Level_Created)); + Acc.Position := Acc.Stack.Last; + end; + else + Acc.Stack.Update_Element (Acc.Position, Process'Access); + end if; + end Push; + + + + procedure Pop (Acc : in out String_Accumulator_Linked_List) is + use type Lists.Cursor; + begin + if Acc.Stack.Is_Empty then + raise Program_Error; + end if; + Lists.Previous (Acc.Position); + if Acc.Position = Lists.No_Element then + Acc.Position := Lists.First (Acc.Stack); + raise Program_Error; + end if; + end Pop; + + + + procedure Soft_Reset (Acc : in out String_Accumulator_Linked_List) is + procedure Process (Element : in out String_Accumulator'Class); + + procedure Process (Element : in out String_Accumulator'Class) is + begin + Element.Soft_Reset; + end Process; + begin + Initialize_If_Needed (Acc); + Acc.Position := Lists.First (Acc.Stack); + Acc.Stack.Update_Element (Acc.Position, Process'Access); + end Soft_Reset; + + + + function Tail (Acc : String_Accumulator_Linked_List; Size : Natural) + return String + is + procedure Process (Element : String_Accumulator'Class); + + Result : String (1 .. Size); + Actual_Size : Natural; + + procedure Process (Element : String_Accumulator'Class) + is + Output : constant String := Tail (Element, Size); + begin + Actual_Size := Output'Length; + Result (1 .. Actual_Size) := Output; + end Process; + begin + if Acc.Stack.Is_Empty then + return ""; + else + Lists.Query_Element (Acc.Position, Process'Access); + return Result (1 .. Actual_Size); + end if; + end Tail; + + + + function To_String (Acc : String_Accumulator_Linked_List) return String is + begin + if Acc.Stack.Is_Empty then + return ""; + end if; + + declare + procedure Process (Element : String_Accumulator'Class); + + Result : String (1 .. Acc.Length); + + procedure Process (Element : String_Accumulator'Class) is + begin + Result := Element.To_String; + end Process; + begin + Lists.Query_Element (Acc.Position, Process'Access); + return Result; + end; + end To_String; + + + + procedure To_String (Acc : String_Accumulator_Linked_List; + Output : out String) is + begin + if Acc.Stack.Is_Empty then + return; + end if; + + declare + procedure Process (Element : String_Accumulator'Class); + + procedure Process (Element : String_Accumulator'Class) is + begin + Element.To_String (Output); + end Process; + begin + Lists.Query_Element (Acc.Position, Process'Access); + end; + end To_String; + + + + procedure Unappend (From : in out String_Accumulator_Linked_List; + Text : String) + is + procedure Process (Element : in out String_Accumulator'Class); + + procedure Process (Element : in out String_Accumulator'Class) is + begin + Element.Unappend (Text); + end Process; + begin + if not From.Stack.Is_Empty then + From.Stack.Update_Element (From.Position, Process'Access); + end if; + end Unappend; + +end Natools.Accumulators.String_Accumulator_Linked_Lists; ADDED src/natools-accumulators-string_accumulator_linked_lists.ads Index: src/natools-accumulators-string_accumulator_linked_lists.ads ================================================================== --- src/natools-accumulators-string_accumulator_linked_lists.ads +++ src/natools-accumulators-string_accumulator_linked_lists.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Accumulators.String_Accumulator_Linked_Lists is a simple -- +-- implementation of String_Accumulator_Stack using an external function to -- +-- generate the String_Accumulator elements when the stack is grown. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Indefinite_Doubly_Linked_Lists; + +package Natools.Accumulators.String_Accumulator_Linked_Lists is + pragma Preelaborate (String_Accumulator_Linked_Lists); + + type String_Accumulator_Linked_List + (Build : not null access function (Depth : Positive) + return String_Accumulator'Class) + is new String_Accumulator_Stack with private; + + procedure Append (To : in out String_Accumulator_Linked_List; + Text : String); + -- Append the given String to the internal buffer + + procedure Hard_Reset (Acc : in out String_Accumulator_Linked_List); + -- Empty the internal buffer and free all possible memory + + function Length (Acc : String_Accumulator_Linked_List) return Natural; + -- Return the length of the internal buffer + + procedure Push (Acc : in out String_Accumulator_Linked_List); + -- Push the current internal buffer and start with an empty one + + procedure Pop (Acc : in out String_Accumulator_Linked_List); + -- Drop the current internal buffer and use the previsouly pushed one + -- instead + -- Raise Program_Error when trying to pop the last internal buffer + + procedure Soft_Reset (Acc : in out String_Accumulator_Linked_List); + -- Empty the internal buffer for reuse + + function Tail (Acc : String_Accumulator_Linked_List; Size : Natural) + return String; + -- Return the last characters from the internal buffer + + function To_String (Acc : String_Accumulator_Linked_List) return String; + -- Output the whole internal buffer as a String + + procedure To_String (Acc : String_Accumulator_Linked_List; + Output : out String); + -- Write the whole internal buffer into the String, which must be + -- large enough. + + procedure Unappend (From : in out String_Accumulator_Linked_List; + Text : String); + -- Remove the given suffix from the internal buffer + -- Do nothing if the given text is not a prefix the internal buffer + +private + + package Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists + (Element_Type => String_Accumulator'Class); + + type String_Accumulator_Linked_List + (Build : not null access function (Depth : Positive) + return String_Accumulator'Class) + is new String_Accumulator_Stack with + record + Stack : Lists.List; + Position : Lists.Cursor; + end record; + + procedure Initialize_If_Needed + (Object : in out String_Accumulator_Linked_List); + +end Natools.Accumulators.String_Accumulator_Linked_Lists; ADDED src/natools-accumulators.ads Index: src/natools-accumulators.ads ================================================================== --- src/natools-accumulators.ads +++ src/natools-accumulators.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Accumulators is a collection of interfaces for data structures -- +-- that allow efficient accumulation of data. -- +-- -- +-- String_Accumulator is meant for creation of long strings through -- +-- repeated calls of Append, and later retrieval of the full buffer through -- +-- one of the To_String subprograms. Length, Tail and Unappend are -- +-- helper utilities that might not be very efficient but can occasionnally -- +-- be useful. Hard_Reset and Soft_Reset both clear the internal state, with -- +-- Soft_Reset aimed for speed while Hard_Reset aims for best memory release -- +-- -- +-- String_Accumulator_Stack adds a stack structure on top of -- +-- String_Accumulator, to allow temporary substrings to be created using -- +-- similar facilities. All operations on String_Accumulator except -- +-- Hard_Reset and Soft_Reset, when applied to String_Accumulator_Stack, are -- +-- meant to be forwarded to the top accumulator of the stack. Push and Pop -- +-- change the stack state, while Hard_Reset and Soft_Reset apply to the -- +-- whole stack, with the same semantics as for String_Accumulator. -- +------------------------------------------------------------------------------ + +package Natools.Accumulators is + pragma Pure (Accumulators); + + type String_Accumulator is interface; + + procedure Append (To : in out String_Accumulator; Text : String) + is abstract; + -- Append the given String to the internal buffer + + procedure Hard_Reset (Acc : in out String_Accumulator) + is abstract; + -- Empty the internal buffer and free all possible memory + + function Length (Acc : String_Accumulator) return Natural + is abstract; + -- Return the length of the internal buffer + + procedure Soft_Reset (Acc : in out String_Accumulator) + is abstract; + -- Empty the internal buffer for reuse + + function Tail (Acc : String_Accumulator; Size : Natural) return String + is abstract; + -- Return the last characters from the internal buffer + + function To_String (Acc : String_Accumulator) return String + is abstract; + -- Output the whole internal buffer as a String + + procedure To_String (Acc : String_Accumulator; Output : out String) + is abstract; + -- Write the whole internal buffer into the String, which must be + -- large enough. + + procedure Unappend (From : in out String_Accumulator; Text : String) + is abstract; + -- Remove the given suffix from the internal buffer + -- Do nothing if the given text is not a prefix the internal buffer + + + + type String_Accumulator_Stack is interface and String_Accumulator; + + procedure Push (Acc : in out String_Accumulator_Stack) + is abstract; + -- Push the current internal buffer and start with an empty one + + procedure Pop (Acc : in out String_Accumulator_Stack) + is abstract; + -- Drop the current internal buffer and use the previsouly pushed one + -- instead + -- Raise Program_Error when trying to pop the last internal buffer + +end Natools.Accumulators; ADDED src/natools-chunked_strings.adb Index: src/natools-chunked_strings.adb ================================================================== --- src/natools-chunked_strings.adb +++ src/natools-chunked_strings.adb @@ -0,0 +1,2235 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Strings; +with Ada.Strings.Fixed; +with Ada.Unchecked_Deallocation; + +package body Natools.Chunked_Strings is + + package Fixed renames Ada.Strings.Fixed; + + type Relation is (Equal, Greater, Lesser); + + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Allocated_Size (Source : in Chunked_String) return Natural; + pragma Inline (Allocated_Size); + -- Return the number of Characters that can currently fit in Source + + + function Chunks_For (Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive) + return Natural; + pragma Inline (Chunks_For); + -- Return the number of chunks to accommodate Size characters + + + generic + type Map_Type is private; + with function Count (Source : in String; + Pattern : in String; + Mapping : in Map_Type) + return Natural; + function Count_Gen (Source : in Chunked_String; + Pattern : in String; + Mapping : in Map_Type) + return Natural; + -- Count the number of non-overlapping occurrences of the pattern + + + function Compare + (Left : in Chunk_Array; + Left_Size : in Natural; + Right : in Chunk_Array; + Right_Size : in Natural) + return Relation; + function Compare + (Left : in Chunk_Array_Access; + Left_Size : in Natural; + Right : in Chunk_Array_Access; + Right_Size : in Natural) + return Relation; + function Compare + (Left : in Chunk_Array; + Left_Size : in Natural; + Right : in String) + return Relation; + function Compare + (Left : in Chunk_Array_Access; + Left_Size : in Natural; + Right : in String) + return Relation; + -- String comparisons + + + procedure Fill (Data : in out Chunk_Array; + From : in Positive; + Count : in Natural; + C : in Character; + Chunk_Size : in Positive); + -- Fill an area of the chunks with the given Character + + + procedure Free (Data : in out Chunk_Array_Access); + -- Free data associated to all chunks and to the chunk array + + + generic + type Map_Type is private; + with function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Ada.Strings.Direction; + Map : Map_Type) + return Natural; + function Index_Gen + (Source : Chunked_String; + Pattern : String; + From : Positive; + Going : Ada.Strings.Direction; + Map : Map_Type) + return Natural; + -- Search for a pattern in a source as described in the ARM + + + procedure Move (Target : in out Chunk_Array; + Target_Position : in Positive; + Source : in out Chunk_Array; + Source_Position : in Positive; + Length : in Natural); + -- Moves characters from one Chunk_Array to another, even when they + -- do not have the same chunk size + + + procedure Move (Target : in out Chunk_Array; + Source : in String; + Position : in Positive; + Chunk_Size : in Positive); + -- Writes the string in the chunk array, which must be large enough + + + procedure Move (Target : out String; + Source : in Chunk_Array; + From : in Positive); + -- Fills a string using characters from the Chunk_Array + + + procedure Move (Data : in out Chunk_Array; + Target_Position : in Positive; + Source_Position : in Positive; + Length : in Positive; + Chunk_Size : in Positive); + -- Move a slice of data inside a given chunk array + + + procedure Resize_Chunk (Chunk : in out String_Access; + Size : in Positive); + -- Resize a chunk to the target set + + + procedure Resize_Chunks (Data : in out Chunk_Array_Access; + Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive; + Can_Shrink : in Boolean := True); + -- Resize Data to fit Size characters + + + procedure Trim_Bounds (Source : in Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set; + Low : out Positive; + High : out Natural); + -- Compute slice bounds of the trimmed result + + + function Units_For (Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive) + return Natural; + pragma Inline (Units_For); + -- Return the number of allocation units in the last chunk + + + + --------------------------------------- + -- Chunked_String memory subprograms -- + --------------------------------------- + + function Allocated_Size (Source : in Chunked_String) return Natural is + begin + if Source.Data = null or else Source.Data'Last < 1 then + return 0; + end if; + + return (Source.Data'Last - 1) * Source.Chunk_Size + + Source.Data (Source.Data'Last)'Last; + end Allocated_Size; + + + + function Chunks_For (Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive) + return Natural is + begin + pragma Unreferenced (Allocation_Unit); + return (Size + Chunk_Size - 1) / Chunk_Size; + end Chunks_For; + + + + procedure Free (Data : in out Chunk_Array_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Chunk_Array, Chunk_Array_Access); + begin + if Data = null then + return; + end if; + for J in Data'Range loop + Free (Data (J)); + end loop; + Deallocate (Data); + end Free; + + + + procedure Resize_Chunk (Chunk : in out String_Access; + Size : in Positive) + is + New_Chunk : String_Access; + begin + if Size /= Chunk'Length then + New_Chunk := new String (1 .. Size); + if Size < Chunk'Length then + New_Chunk.all := Chunk (Chunk'First .. Chunk'First + Size - 1); + else + New_Chunk.all (1 .. Chunk'Length) := Chunk.all; + end if; + Free (Chunk); + Chunk := New_Chunk; + end if; + end Resize_Chunk; + + + + procedure Resize_Chunks (Data : in out Chunk_Array_Access; + Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive; + Can_Shrink : in Boolean := True) + is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Chunk_Array, Chunk_Array_Access); + + Chunk_Nb : constant Natural + := Chunks_For (Size, Chunk_Size, Allocation_Unit); + Last_Chunk_Size : constant Natural + := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; + begin + if Size = 0 then + if Can_Shrink then + Free (Data); + end if; + return; + end if; + pragma Assert (Chunk_Nb > 0); + + if Data = null or else Data'Length < Chunk_Nb then + declare + First_New : Positive := 1; + New_Data : Chunk_Array_Access := new Chunk_Array (1 .. Chunk_Nb); + begin + if Data /= null then + Resize_Chunk (Data (Data'Last), Chunk_Size); + New_Data (1 .. Data'Last) := Data.all; + First_New := Data'Last + 1; + Deallocate (Data); + end if; + Data := New_Data; + for J in First_New .. Data'Last - 1 loop + Data (J) := new String (1 .. Chunk_Size); + end loop; + Data (Data'Last) := new String (1 .. Last_Chunk_Size); + end; + elsif Data'Length > Chunk_Nb then + if Can_Shrink then + declare + New_Data : constant Chunk_Array_Access + := new Chunk_Array (1 .. Chunk_Nb); + begin + Resize_Chunk (Data (Chunk_Nb), Last_Chunk_Size); + for J in Chunk_Nb + 1 .. Data'Last loop + Free (Data (J)); + end loop; + New_Data.all := Data (1 .. Chunk_Nb); + Data := New_Data; + end; + end if; + else -- Data'Length = Chunk_Nb + if Last_Chunk_Size > Data (Data'Last).all'Last or Can_Shrink then + Resize_Chunk (Data (Data'Last), Last_Chunk_Size); + end if; + end if; + end Resize_Chunks; + + + + function Units_For (Size : in Natural; + Chunk_Size : in Positive; + Allocation_Unit : in Positive) + return Natural is + begin + return (((Size + Chunk_Size - 1) mod Chunk_Size + 1) + + Allocation_Unit - 1) / Allocation_Unit; + end Units_For; + + + + --------------------------- + -- Low-level subprograms -- + --------------------------- + + function Compare + (Left : in Chunk_Array; + Left_Size : in Natural; + Right : in Chunk_Array; + Right_Size : in Natural) + return Relation + is + L_Chunk : Positive := Left'First; + L_Pos : Positive := Left (L_Chunk).all'First; + L_Remain : Natural := Left_Size; + R_Chunk : Positive := Right'First; + R_Pos : Positive := Right (R_Chunk).all'First; + R_Remain : Natural := Right_Size; + Step : Positive; + begin + loop + Step := Positive'Min + (Natural'Min (Left (L_Chunk).all'Last - L_Pos + 1, + L_Remain), + Natural'Min (Right (R_Chunk).all'Last - R_Pos + 1, + R_Remain)); + declare + L_Part : String + renames Left (L_Chunk).all (L_Pos .. L_Pos + Step - 1); + R_Part : String + renames Right (R_Chunk).all (R_Pos .. R_Pos + Step - 1); + begin + if L_Part < R_Part then + return Lesser; + elsif L_Part > R_Part then + return Greater; + end if; + end; + + L_Remain := L_Remain - Step; + R_Remain := R_Remain - Step; + if L_Remain = 0 and R_Remain = 0 then + return Equal; + elsif L_Remain = 0 then + return Lesser; + elsif R_Remain = 0 then + return Greater; + end if; + + L_Pos := L_Pos + Step; + R_Pos := R_Pos + Step; + + if L_Pos > Left (L_Chunk).all'Last then + if L_Chunk = Left'Last then + if R_Pos <= Right (R_Chunk).all'Last + or R_Chunk < Right'Last + then + return Lesser; + else + return Equal; + end if; + end if; + L_Chunk := L_Chunk + 1; + L_Pos := Left (L_Chunk).all'First; + end if; + if R_Pos > Right (R_Chunk).all'Last then + if R_Chunk = Right'Last then + return Greater; + end if; + R_Chunk := R_Chunk + 1; + R_Pos := Right (R_Chunk).all'First; + end if; + end loop; + end Compare; + + + + function Compare + (Left : in Chunk_Array_Access; + Left_Size : in Natural; + Right : in Chunk_Array_Access; + Right_Size : in Natural) + return Relation is + begin + if Left = null or Left_Size = 0 then + if Right = null or Right_Size = 0 then + return Equal; + else + return Lesser; + end if; + else + if Right = null or Right_Size = 0 then + return Greater; + else + return Compare (Left.all, Left_Size, Right.all, Right_Size); + end if; + end if; + end Compare; + + + + function Compare + (Left : in Chunk_Array; + Left_Size : in Natural; + Right : in String) + return Relation + is + Chunk : Positive := Left'First; + L_Pos : Positive := Left (Chunk).all'First; + L_Remain : Natural := Left_Size; + R_Pos : Positive := Right'First; + Step : Positive; + begin + loop + Step + := Positive'Min (Positive'Min (Left (Chunk).all'Last - L_Pos + 1, + L_Remain), + Right'Last - R_Pos + 1); + declare + L_Part : String + renames Left (Chunk).all (L_Pos .. L_Pos + Step - 1); + R_Part : String + renames Right (R_Pos .. R_Pos + Step - 1); + begin + if L_Part < R_Part then + return Lesser; + elsif L_Part > R_Part then + return Greater; + end if; + end; + + L_Remain := L_Remain - Step; + if L_Remain = 0 then + if R_Pos + Step > Right'Last then + return Equal; + else + return Lesser; + end if; + end if; + + L_Pos := L_Pos + Step; + R_Pos := R_Pos + Step; + + if L_Pos > Left (Chunk).all'Last then + if Chunk = Left'Last then + if R_Pos <= Right'Last then + return Lesser; + else + return Equal; + end if; + end if; + Chunk := Chunk + 1; + L_Pos := Left (Chunk).all'First; + end if; + if R_Pos > Right'Last then + return Greater; + end if; + end loop; + end Compare; + + + + function Compare + (Left : in Chunk_Array_Access; + Left_Size : in Natural; + Right : in String) + return Relation is + begin + if Left = null or Left_Size = 0 then + if Right'Length = 0 then + return Equal; + else + return Lesser; + end if; + else + if Right'Length = 0 then + return Greater; + else + return Compare (Left.all, Left_Size, Right); + end if; + end if; + end Compare; + + + + procedure Fill (Data : in out Chunk_Array; + From : in Positive; + Count : in Natural; + C : in Character; + Chunk_Size : in Positive) + is + Chunk : Positive := (From - 1) / Chunk_Size + 1; + Offset : Positive := (From - 1) mod Chunk_Size + 1; + Done : Natural := 0; + Step : Positive; + begin + while Done < Count loop + Step := Positive'Min (Count - Done, + Data (Chunk).all'Last - Offset + 1); + Data (Chunk).all (Offset .. Offset + Step - 1) + := Ada.Strings.Fixed."*" (Step, C); + Chunk := Chunk + 1; + Offset := 1; + Done := Done + Step; + end loop; + end Fill; + + + + function Is_Valid (Source : in Chunked_String) return Boolean is + begin + -- Null data is only acceptable when the string is empty. + if Source.Data = null then + return Source.Size = 0; + end if; + + -- Data array must contain non-null chunks of even size + declare + D : Chunk_Array renames Source.Data.all; + begin + if D'First /= 1 then + return False; + end if; + for J in D'Range loop + if D (J) = null then + return False; + end if; + + if D (J).all'First /= 1 or + (J < D'Last and D (J).all'Last /= Source.Chunk_Size) + then + return False; + end if; + end loop; + end; + + -- Real size must be smaller than allocated size + if Source.Size > Allocated_Size (Source) then + return False; + end if; + + return True; + end Is_Valid; + + + + procedure Move (Target : in out Chunk_Array; + Target_Position : in Positive; + Source : in out Chunk_Array; + Source_Position : in Positive; + Length : in Natural) + is + Count : Natural := 0; + S_Chunk : Positive; + S_Pos : Positive; + T_Chunk : Positive; + T_Pos : Positive; + begin + S_Chunk := Target'First; + S_Pos := 1; + while S_Pos + Source (S_Chunk).all'Length <= Source_Position loop + S_Pos := S_Pos + Source (S_Chunk).all'Length; + S_Chunk := S_Chunk + 1; + end loop; + S_Pos := Source_Position + 1 - S_Pos; + + T_Chunk := Target'First; + T_Pos := 1; + while T_Pos + Target (T_Chunk).all'Length <= Target_Position loop + T_Pos := T_Pos + Target (T_Chunk).all'Length; + T_Chunk := T_Chunk + 1; + end loop; + T_Pos := Target_Position + 1 - T_Pos; + + while Count < Length loop + declare + S_String : String renames Source (S_Chunk).all; + T_String : String renames Target (T_Chunk).all; + Step_C : constant Positive := Length - Count; + Step_S : constant Positive := S_String'Last - S_Pos + 1; + Step_T : constant Positive := T_String'Last - T_Pos + 1; + Step : constant Positive + := Positive'Min (Step_C, Positive'Min (Step_S, Step_T)); + begin + T_String (T_Pos .. T_Pos + Step - 1) + := S_String (S_Pos .. S_Pos + Step - 1); + Count := Count + Step; + exit when Count >= Length; + S_Pos := S_Pos + Step; + T_Pos := T_Pos + Step; + if S_Pos > S_String'Last then + S_Chunk := S_Chunk + 1; + S_Pos := Source (S_Chunk).all'First; + end if; + if T_Pos > T_String'Last then + T_Chunk := T_Chunk + 1; + T_Pos := Target (T_Chunk).all'First; + end if; + end; + end loop; + end Move; + + + + procedure Move (Target : in out Chunk_Array; + Source : in String; + Position : in Positive; + Chunk_Size : in Positive) + is + Last_Position : constant Positive := Position + Source'Length - 1; + First_Chunk : constant Positive := (Position - 1) / Chunk_Size + 1; + First_Offset : constant Positive := (Position - 1) mod Chunk_Size + 1; + Last_Chunk : constant Positive + := (Last_Position - 1) / Chunk_Size + 1; + Last_Offset : constant Positive + := (Last_Position - 1) mod Chunk_Size + 1; + Current : Positive; + begin + if First_Chunk = Last_Chunk then + Target (First_Chunk).all (First_Offset .. Last_Offset) := Source; + else + Current := Source'First + Chunk_Size - First_Offset + 1; + Target (First_Chunk).all (First_Offset .. Chunk_Size) + := Source (Source'First .. Current - 1); + for J in First_Chunk + 1 .. Last_Chunk - 1 loop + Target (J).all := Source (Current .. Current + Chunk_Size - 1); + Current := Current + Chunk_Size; + end loop; + Target (Last_Chunk).all (1 .. Last_Offset) + := Source (Current .. Source'Last); + end if; + end Move; + + + + procedure Move (Target : out String; + Source : in Chunk_Array; + From : in Positive) + is + T_Pos : Positive := Target'First; + S_Pos : Positive := 1; + Chunk : Positive := 1; + Step : Positive; + begin + while S_Pos + Source (Chunk).all'Length <= From loop + S_Pos := S_Pos + Source (Chunk).all'Length; + Chunk := Chunk + 1; + end loop; + S_Pos := From - S_Pos + 1; + + Step := Source (Chunk).all'Last - S_Pos + 1; + if Target'Length <= Step then + Target := Source (Chunk).all (S_Pos .. S_Pos + Target'Length - 1); + return; + end if; + + Target (T_Pos .. T_Pos + Step - 1) + := Source (Chunk).all (S_Pos .. Source (Chunk).all'Last); + T_Pos := T_Pos + Step; + Chunk := Chunk + 1; + + while T_Pos <= Target'Last loop + Step := Positive'Min (Source (Chunk).all'Length, + Target'Last - T_Pos + 1); + Target (T_Pos .. T_Pos + Step - 1) + := Source (Chunk).all (1 .. Step); + T_Pos := T_Pos + Step; + Chunk := Chunk + 1; + end loop; + end Move; + + + + procedure Move (Data : in out Chunk_Array; + Target_Position : in Positive; + Source_Position : in Positive; + Length : in Positive; + Chunk_Size : in Positive) is + begin + if Target_Position < Source_Position then + declare + S_Chunk : Positive := (Source_Position - 1) / Chunk_Size + 1; + S_Pos : Positive := (Source_Position - 1) mod Chunk_Size + 1; + T_Chunk : Positive := (Target_Position - 1) / Chunk_Size + 1; + T_Pos : Positive := (Target_Position - 1) mod Chunk_Size + 1; + Count : Natural := 0; + Step : Positive; + begin + while Count < Length loop + Step := Positive'Min + (Positive'Min (Data (S_Chunk).all'Last - S_Pos + 1, + Data (T_Chunk).all'Last - T_Pos + 1), + Length - Count); + Data (T_Chunk).all (T_Pos .. T_Pos + Step - 1) + := Data (S_Chunk).all (S_Pos .. S_Pos + Step - 1); + Count := Count + Step; + + S_Pos := S_Pos + Step; + if S_Pos > Chunk_Size then + S_Chunk := S_Chunk + 1; + S_Pos := 1; + end if; + + T_Pos := T_Pos + Step; + if T_Pos > Chunk_Size then + T_Chunk := T_Chunk + 1; + T_Pos := 1; + end if; + end loop; + end; + elsif Target_Position > Source_Position then + declare + S_End : constant Positive := Source_Position + Length - 1; + T_End : constant Positive := Target_Position + Length - 1; + S_Chunk : Positive := (S_End - 1) / Chunk_Size + 1; + S_Pos : Positive := (S_End - 1) mod Chunk_Size + 1; + T_Chunk : Positive := (T_End - 1) / Chunk_Size + 1; + T_Pos : Positive := (T_End - 1) mod Chunk_Size + 1; + Count : Natural := 0; + Step : Positive; + begin + loop + Step := Positive'Min (Positive'Min (S_Pos, T_Pos), + Length - Count); + Data (T_Chunk).all (T_Pos - Step + 1 .. T_Pos) + := Data (S_Chunk).all (S_Pos - Step + 1 .. S_Pos); + Count := Count + Step; + exit when Count = Length; + pragma Assert (Count < Length); + + if S_Pos <= Step then + S_Chunk := S_Chunk - 1; + S_Pos := Chunk_Size; + else + S_Pos := S_Pos - Step; + end if; + + if T_Pos <= Step then + T_Chunk := T_Chunk - 1; + T_Pos := Chunk_Size; + else + T_Pos := T_Pos - Step; + end if; + end loop; + end; + end if; + end Move; + + + + -------------------------------------------------- + -- Public interface specific to Chunked_Strings -- + -------------------------------------------------- + + + function Build (Depth : Positive) + return Natools.Accumulators.String_Accumulator'Class + is + pragma Unreferenced (Depth); + begin + return Null_Chunked_String; + end Build; + + + + function Duplicate (Source : in Chunked_String) return Chunked_String is + Data : Chunk_Array_Access := null; + begin + if Source.Data /= null then + Data := new Chunk_Array (Source.Data'Range); + for J in Source.Data'Range loop + Data (J) := new String'(Source.Data (J).all); + end loop; + end if; + + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Source.Chunk_Size, + Allocation_Unit => Source.Allocation_Unit, + Size => Source.Size, + Data => Data); + end Duplicate; + + + + procedure Hard_Reset (Str : in out Chunked_String) is + begin + Free (Str.Data); + end Hard_Reset; + + + + procedure Soft_Reset (Str : in out Chunked_String) is + begin + Str.Size := 0; + end Soft_Reset; + + + + procedure To_String (Source : Chunked_String; Output : out String) is + Position : Positive := Output'First; + Step : Positive; + begin + if Source.Size > 0 then + for J in Source.Data'Range loop + Step := Positive'Min (Source.Data (J).all'Length, + Source.Size - Position + 1); + Output (Position .. Position + Step - 1) + := Source.Data (J).all (1 .. Step); + Position := Position + Step; + exit when Position > Source.Size; + end loop; + pragma Assert (Position = Source.Size + 1); + end if; + end To_String; + + + + ------------------------------------------- + -- String_Accumulator specific interface -- + ------------------------------------------- + + + function Tail (Source : in Chunked_String; Size : in Natural) + return String + is + Actual_Size : constant Natural := Natural'Min (Size, Source.Size); + begin + return Slice (Source, Source.Size - Actual_Size + 1, Source.Size); + end Tail; + + + + procedure Unappend (From : in out Chunked_String; Text : in String) is + begin + if Text'Length <= From.Size + and then String'(Tail (From, Text'Length)) = Text + then + From.Size := From.Size - Text'Length; + end if; + end Unappend; + + + + ------------------------ + -- Standard interface -- + ------------------------ + + function Length (Source : in Chunked_String) return Natural is + begin + return Source.Size; + end Length; + + + + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + + procedure Free (X : in out String_Access) is + begin + Deallocate (X); + end Free; + + + procedure Free_Extra_Memory (From : in out Chunked_String) is + begin + Resize_Chunks (From.Data, From.Size, + From.Chunk_Size, From.Allocation_Unit, + Can_Shrink => True); + end Free_Extra_Memory; + + + procedure Preallocate (Str : in out Chunked_String; Size : Natural) is + begin + Resize_Chunks (Str.Data, Size, Str.Chunk_Size, Str.Allocation_Unit, + Can_Shrink => False); + end Preallocate; + + + function To_Chunked_String + (Source : in String; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String + is + Data : Chunk_Array_Access := null; + begin + if Source'Length > 0 then + Resize_Chunks (Data, Source'Length, Chunk_Size, Allocation_Unit); + Move (Data.all, Source, 1, Chunk_Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Source'Length, + Data => Data); + end To_Chunked_String; + + + + function To_Chunked_String + (Length : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String + is + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Length, Chunk_Size, Allocation_Unit); + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Length, + Data => Data); + end To_Chunked_String; + + + + function To_String (Source : in Chunked_String) return String is + Value : String (1 .. Source.Size); + begin + To_String (Source, Value); + return Value; + end To_String; + + + + procedure Set_Chunked_String + (Target : out Chunked_String; + Source : in String; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) is + begin + Resize_Chunks (Target.Data, Source'Length, + Chunk_Size, Allocation_Unit, + Can_Shrink => True); + Target.Chunk_Size := Chunk_Size; + Target.Allocation_Unit := Allocation_Unit; + Target.Size := Source'Length; + if Target.Size > 0 then + Move (Target.Data.all, Source, 1, Chunk_Size); + end if; + end Set_Chunked_String; + + + + procedure Append (Source : in out Chunked_String; + New_Item : in Chunked_String) + is + New_Size : constant Natural := Source.Size + New_Item.Size; + begin + Resize_Chunks (Source.Data, New_Size, + Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + Move (Source.Data.all, Source.Size + 1, + New_Item.Data.all, 1, + New_Item.Size); + Source.Size := New_Size; + end Append; + + + + procedure Append (Source : in out Chunked_String; + New_Item : in String) + is + New_Size : constant Natural := Source.Size + New_Item'Length; + begin + Resize_Chunks (Source.Data, New_Size, + Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + Move (Source.Data.all, New_Item, Source.Size + 1, Source.Chunk_Size); + Source.Size := New_Size; + end Append; + + + + procedure Append (Source : in out Chunked_String; + New_Item : in Character) + is + S : constant String (1 .. 1) := (1 => New_Item); + begin + Append (Source, S); + end Append; + + + + function "&" (Left, Right : in Chunked_String) + return Chunked_String + is + Size : constant Natural := Left.Size + Right.Size; + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); + if Left.Size > 0 then + Move (Data.all, 1, Left.Data.all, 1, Left.Size); + end if; + if Right.Size > 0 then + Move (Data.all, 1 + Left.Size, Right.Data.all, 1, Right.Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Default_Chunk_Size, + Allocation_Unit => Default_Allocation_Unit, + Size => Size, + Data => Data); + end "&"; + + + + function "&" (Left : in Chunked_String; Right : in String) + return Chunked_String + is + Size : constant Natural := Left.Size + Right'Length; + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); + if Left.Size > 0 then + Move (Data.all, 1, Left.Data.all, 1, Left.Size); + end if; + if Right'Length > 0 then + Move (Data.all, Right, 1 + Left.Size, Default_Chunk_Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Default_Chunk_Size, + Allocation_Unit => Default_Allocation_Unit, + Size => Size, + Data => Data); + end "&"; + + + + function "&" (Left : in String; Right : in Chunked_String) + return Chunked_String + is + Size : constant Natural := Left'Length + Right.Size; + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); + if Left'Length > 0 then + Move (Data.all, Left, 1, Default_Chunk_Size); + end if; + if Right.Size > 0 then + Move (Data.all, 1 + Left'Length, Right.Data.all, 1, Right.Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Default_Chunk_Size, + Allocation_Unit => Default_Allocation_Unit, + Size => Size, + Data => Data); + end "&"; + + + + function "&" (Left : in Chunked_String; Right : in Character) + return Chunked_String + is + Size : constant Natural := Left.Size + 1; + Allocation_Unit : constant Positive := Default_Allocation_Unit; + Chunk_Size : constant Positive := Default_Chunk_Size; + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); + if Left.Size > 0 then + Move (Data.all, 1, Left.Data.all, 1, Left.Size); + end if; + declare + Position : constant Positive := Left.Size + 1; + Chunk : constant Positive := (Position - 1) / Chunk_Size + 1; + Offset : constant Positive := (Position - 1) mod Chunk_Size + 1; + begin + Data (Chunk).all (Offset) := Right; + end; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Size, + Data => Data); + end "&"; + + + + function "&" (Left : in Character; Right : in Chunked_String) + return Chunked_String + is + Size : constant Natural := 1 + Right.Size; + Data : Chunk_Array_Access := null; + begin + Resize_Chunks (Data, Size, Default_Chunk_Size, Default_Allocation_Unit); + Data (1).all (1) := Left; + if Right.Size > 0 then + Move (Data.all, 2, Right.Data.all, 1, Right.Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Default_Chunk_Size, + Allocation_Unit => Default_Allocation_Unit, + Size => Size, + Data => Data); + end "&"; + + + + function Element (Source : in Chunked_String; + Index : in Positive) + return Character + is + Chunk : constant Positive := (Index - 1) / Source.Chunk_Size + 1; + Offset : constant Positive := (Index - 1) mod Source.Chunk_Size + 1; + begin + if Index > Source.Size then + raise Ada.Strings.Index_Error; + end if; + return Source.Data (Chunk).all (Offset); + end Element; + + + + procedure Replace_Element (Source : in out Chunked_String; + Index : in Positive; + By : in Character) + is + Chunk : constant Positive := (Index - 1) / Source.Chunk_Size + 1; + Offset : constant Positive := (Index - 1) mod Source.Chunk_Size + 1; + begin + if Index > Source.Size then + raise Ada.Strings.Index_Error; + end if; + Source.Data (Chunk).all (Offset) := By; + end Replace_Element; + + + + function Slice (Source : in Chunked_String; + Low : in Positive; + High : in Natural) + return String + is + Returned : String (Low .. High); + begin + if Low > Source.Size + 1 or High > Source.Size then + raise Ada.Strings.Index_Error; + end if; + if High >= Low then + Move (Returned, Source.Data.all, Low); + end if; + return Returned; + end Slice; + + + + function Chunked_Slice + (Source : in Chunked_String; + Low : in Positive; + High : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String + is + Data : Chunk_Array_Access := null; + Size : Natural := 0; + begin + if Low > Source.Size + 1 or High > Source.Size then + raise Ada.Strings.Index_Error; + end if; + if Low <= High then + Size := High - Low + 1; + Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); + Move (Data.all, 1, Source.Data.all, Low, Size); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Size, + Data => Data); + end Chunked_Slice; + + + + procedure Chunked_Slice + (Source : in Chunked_String; + Target : out Chunked_String; + Low : in Positive; + High : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) is + begin + if Low > Source.Size + 1 or High > Source.Size then + raise Ada.Strings.Index_Error; + end if; + Target.Chunk_Size := Chunk_Size; + Target.Allocation_Unit := Allocation_Unit; + if Low <= High then + Target.Size := High - Low + 1; + Resize_Chunks (Target.Data, Target.Size, + Chunk_Size, Allocation_Unit, + Can_Shrink => True); + Move (Target.Data.all, 1, Source.Data.all, Low, Target.Size); + else + Target.Size := 0; + Target.Data := null; + end if; + end Chunked_Slice; + + + + function "=" (Left, Right : in Chunked_String) return Boolean is + begin + return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Equal; + end "="; + + + + function "=" (Left : in Chunked_String; Right : in String) + return Boolean is + begin + return Compare (Left.Data, Left.Size, Right) = Equal; + end "="; + + + + function "=" (Left : in String; Right : in Chunked_String) + return Boolean is + begin + return Compare (Right.Data, Right.Size, Left) = Equal; + end "="; + + + + function "<" (Left, Right : in Chunked_String) return Boolean is + begin + return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Lesser; + end "<"; + + + + function "<" (Left : in Chunked_String; Right : in String) + return Boolean is + begin + return Compare (Left.Data, Left.Size, Right) = Lesser; + end "<"; + + + + function "<" (Left : in String; Right : in Chunked_String) + return Boolean is + begin + return Compare (Right.Data, Right.Size, Left) = Greater; + end "<"; + + + + function "<=" (Left, Right : in Chunked_String) return Boolean is + begin + return Compare (Left.Data, Left.Size, Right.Data, Right.Size) /= Greater; + end "<="; + + + + function "<=" (Left : in Chunked_String; Right : in String) + return Boolean is + begin + return Compare (Left.Data, Left.Size, Right) /= Greater; + end "<="; + + + + function "<=" (Left : in String; Right : in Chunked_String) + return Boolean is + begin + return Compare (Right.Data, Right.Size, Left) /= Lesser; + end "<="; + + + + function ">" (Left, Right : in Chunked_String) return Boolean is + begin + return Compare (Left.Data, Left.Size, Right.Data, Right.Size) = Greater; + end ">"; + + + + function ">" (Left : in Chunked_String; Right : in String) + return Boolean is + begin + return Compare (Left.Data, Left.Size, Right) = Greater; + end ">"; + + + + function ">" (Left : in String; Right : in Chunked_String) + return Boolean is + begin + return Compare (Right.Data, Right.Size, Left) = Lesser; + end ">"; + + + + function ">=" (Left, Right : in Chunked_String) return Boolean is + begin + return Compare (Left.Data, Left.Size, Right.Data, Right.Size) /= Lesser; + end ">="; + + + + function ">=" (Left : in Chunked_String; Right : in String) + return Boolean is + begin + return Compare (Left.Data, Left.Size, Right) /= Lesser; + end ">="; + + + + function ">=" (Left : in String; Right : in Chunked_String) + return Boolean is + begin + return Compare (Right.Data, Right.Size, Left) /= Greater; + end ">="; + + + + function Index_Gen + (Source : Chunked_String; + Pattern : String; + From : Positive; + Going : Ada.Strings.Direction; + Map : Map_Type) + return Natural is + begin + if Pattern = "" then + raise Ada.Strings.Pattern_Error; + end if; + if Source.Size = 0 and From = 1 then + return 0; + end if; + if From > Source.Size then + raise Ada.Strings.Index_Error; + end if; + + declare + Chunk : Positive := (From - 1) / Source.Chunk_Size + 1; + Offset : Positive := (From - 1) mod Source.Chunk_Size + 1; + Buffer : String (1 .. Source.Chunk_Size + Pattern'Length - 1); + Result : Natural; + Span : Positive; + begin + case (Going) is + when Ada.Strings.Forward => + while (Chunk - 1) * Source.Chunk_Size + Pattern'Length + <= Source.Size + loop + Span := Positive'Min + (Source.Chunk_Size + Pattern'Length - 1, + Source.Size - (Chunk - 1) * Source.Chunk_Size); + Move (Buffer (1 .. Span), + Source.Data.all, + (Chunk - 1) * Source.Chunk_Size + 1); + Result := Index (Buffer (1 .. Span), + Pattern, Offset, Going, Map); + if Result /= 0 then + return (Chunk - 1) * Source.Chunk_Size + Result; + end if; + Chunk := Chunk + 1; + Offset := 1; + end loop; + return 0; + when Ada.Strings.Backward => + loop + Span := Positive'Min + (Source.Chunk_Size + Pattern'Length - 1, + Source.Size - (Chunk - 1) * Source.Chunk_Size); + Move (Buffer (1 .. Span), + Source.Data.all, + (Chunk - 1) * Source.Chunk_Size + 1); + Result := Index (Buffer (1 .. Span), + Pattern, Offset, Going, Map); + if Result /= 0 then + return (Chunk - 1) * Source.Chunk_Size + Result; + end if; + exit when Chunk = 1; + Chunk := Chunk - 1; + Offset := Positive'Min (Source.Chunk_Size + Pattern'Length - 1, + Source.Chunk_Size + Offset); + end loop; + return 0; + end case; + end; + end Index_Gen; + + + + function Index_Mapping is + new Index_Gen (Maps.Character_Mapping, Ada.Strings.Fixed.Index); + + function Index (Source : in Chunked_String; + Pattern : in String; + From : in Positive; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural + renames Index_Mapping; + + + + function Index_Mapping_Function is + new Index_Gen (Maps.Character_Mapping_Function, Ada.Strings.Fixed.Index); + + function Index (Source : in Chunked_String; + Pattern : in String; + From : in Positive; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping_Function) + return Natural + renames Index_Mapping_Function; + + + + function Index (Source : in Chunked_String; + Pattern : in String; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural is + begin + case (Going) is + when Ada.Strings.Forward => + return Index (Source, Pattern, 1, Going, Mapping); + when Ada.Strings.Backward => + return Index (Source, Pattern, Source.Size, Going, Mapping); + end case; + end Index; + + + + function Index (Source : in Chunked_String; + Pattern : in String; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping_Function) + return Natural is + begin + case (Going) is + when Ada.Strings.Forward => + return Index (Source, Pattern, 1, Going, Mapping); + when Ada.Strings.Backward => + return Index (Source, Pattern, Source.Size, Going, Mapping); + end case; + end Index; + + + + function Index (Source : in Chunked_String; + Set : in Maps.Character_Set; + From : in Positive; + Test : in Ada.Strings.Membership := Ada.Strings.Inside; + Going : in Ada.Strings.Direction := Ada.Strings.Forward) + return Natural + is + Chunk : Positive := (From - 1) / Source.Chunk_Size + 1; + Offset : Positive := (From - 1) mod Source.Chunk_Size + 1; + Result : Natural; + begin + if From > Source.Size then + raise Ada.Strings.Index_Error; + end if; + + case (Going) is + when Ada.Strings.Forward => + loop + Result := Ada.Strings.Fixed.Index + (Source.Data (Chunk).all, Set, Offset, Test, Going); + if Result /= 0 then + return (Chunk - 1) * Source.Chunk_Size + Result; + end if; + if Chunk = Source.Data'Last then + return 0; + end if; + Chunk := Chunk + 1; + Offset := 1; + end loop; + when Ada.Strings.Backward => + loop + Result := Ada.Strings.Fixed.Index + (Source.Data (Chunk).all, Set, Offset, Test, Going); + if Result /= 0 then + return (Chunk - 1) * Source.Chunk_Size + Result; + end if; + if Chunk = Source.Data'First then + return 0; + end if; + Chunk := Chunk - 1; + Offset := Source.Chunk_Size; + end loop; + end case; + end Index; + + + + function Index (Source : in Chunked_String; + Set : in Maps.Character_Set; + Test : in Ada.Strings.Membership := Ada.Strings.Inside; + Going : in Ada.Strings.Direction := Ada.Strings.Forward) + return Natural is + begin + case Going is + when Ada.Strings.Forward => + return Index (Source, Set, 1, Test, Going); + when Ada.Strings.Backward => + return Index (Source, Set, Source.Size, Test, Going); + end case; + end Index; + + + + function Index_Non_Blank (Source : in Chunked_String; + From : in Positive; + Going : in Ada.Strings.Direction + := Ada.Strings.Forward) + return Natural is + begin + return Index (Source, + Maps.To_Set (Ada.Strings.Space), + From, + Ada.Strings.Outside, + Going); + end Index_Non_Blank; + + + + function Index_Non_Blank (Source : in Chunked_String; + Going : in Ada.Strings.Direction + := Ada.Strings.Forward) + return Natural is + begin + return Index (Source, + Maps.To_Set (Ada.Strings.Space), + Ada.Strings.Outside, + Going); + end Index_Non_Blank; + + + + function Count_Gen (Source : in Chunked_String; + Pattern : in String; + Mapping : in Map_Type) + return Natural + is + Buffer : String (1 .. Source.Chunk_Size + Pattern'Length - 1); + Result : Natural := 0; + Step : Positive; + begin + if Pattern = "" then + raise Ada.Strings.Pattern_Error; + end if; + if Source.Size < Pattern'Length then + return 0; + end if; + + for J in Source.Data'Range loop + Step := Positive'Min (Source.Size - (J - 1) * Source.Chunk_Size, + Source.Chunk_Size + Pattern'Length - 1); + Move (Buffer (1 .. Step), + Source.Data.all, + (J - 1) * Source.Chunk_Size + 1); + Result := Result + Count (Buffer (1 .. Step), + Pattern, + Mapping); + end loop; + return Result; + end Count_Gen; + + function Count_Mapping is + new Count_Gen (Maps.Character_Mapping, Ada.Strings.Fixed.Count); + + function Count (Source : in Chunked_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural + renames Count_Mapping; + + function Count_Mapping_Function is + new Count_Gen (Maps.Character_Mapping_Function, Ada.Strings.Fixed.Count); + + function Count (Source : in Chunked_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping_Function) + return Natural + renames Count_Mapping_Function; + + + + function Count (Source : in Chunked_String; + Set : in Maps.Character_Set) + return Natural + is + Result : Natural := 0; + Done : Natural := 0; + begin + if Source.Size > 0 then + for C in Source.Data'Range loop + declare + Chunk : String renames Source.Data (C).all; + Step : constant Natural + := Natural'Min (Source.Size - Done, Chunk'Length); + begin + Result := Result + Ada.Strings.Fixed.Count + (Chunk (Chunk'First .. Chunk'First + Step - 1), Set); + Done := Done + Step; + end; + end loop; + end if; + return Result; + end Count; + + + + procedure Find_Token (Source : in Chunked_String; + Set : in Maps.Character_Set; + Test : in Ada.Strings.Membership; + First : out Positive; + Last : out Natural) + is + function Invert (M : Ada.Strings.Membership) + return Ada.Strings.Membership; + pragma Inline (Invert); + + N : Natural; + + function Invert (M : Ada.Strings.Membership) + return Ada.Strings.Membership + is + use Ada.Strings; + begin + case M is + when Inside => return Outside; + when Outside => return Inside; + end case; + end Invert; + begin + N := Index (Source, Set, Test); + + if N = 0 then + First := 1; + Last := 0; + else + First := N; + N := Index (Source, Set, First, Invert (Test)); + if N = 0 then + Last := Source.Size; + else + Last := N - 1; + end if; + end if; + end Find_Token; + + + + -- String translation subprograms + + function Translate (Source : in Chunked_String; + Mapping : in Maps.Character_Mapping) + return Chunked_String + is + Data : Chunk_Array_Access := null; + begin + if Source.Data /= null then + Data := new Chunk_Array (Source.Data'Range); + for J in Source.Data'Range loop + Data (J) := new String (Source.Data (J).all'Range); + Data (J).all := Fixed.Translate (Source.Data (J).all, Mapping); + end loop; + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Source.Chunk_Size, + Allocation_Unit => Source.Allocation_Unit, + Size => Source.Size, + Data => Data); + end Translate; + + + + procedure Translate (Source : in out Chunked_String; + Mapping : in Maps.Character_Mapping) is + begin + if Source.Data /= null then + for J in Source.Data'Range loop + Fixed.Translate (Source.Data (J).all, Mapping); + end loop; + end if; + end Translate; + + + + function Translate (Source : in Chunked_String; + Mapping : in Maps.Character_Mapping_Function) + return Chunked_String + is + Data : Chunk_Array_Access := null; + begin + if Source.Data /= null then + Data := new Chunk_Array (Source.Data'Range); + for J in Source.Data'Range loop + Data (J) := new String (Source.Data (J).all'Range); + Data (J).all := Fixed.Translate (Source.Data (J).all, Mapping); + end loop; + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Source.Chunk_Size, + Allocation_Unit => Source.Allocation_Unit, + Size => Source.Size, + Data => Data); + end Translate; + + + + procedure Translate (Source : in out Chunked_String; + Mapping : in Maps.Character_Mapping_Function) is + begin + if Source.Data /= null then + for J in Source.Data'Range loop + Fixed.Translate (Source.Data (J).all, Mapping); + end loop; + end if; + end Translate; + + + + -- String transformation subprograms + + function Replace_Slice (Source : in Chunked_String; + Low : in Positive; + High : in Natural; + By : in String) + return Chunked_String + is + Size : Natural := 0; + Data : Chunk_Array_Access := null; + Hi : Natural := High; + begin + if Low > Source.Size + 1 then + raise Ada.Strings.Index_Error; + end if; + + if High < Low then + Hi := Low - 1; + end if; + + Size := (Low - 1) + By'Length + (Source.Size - Hi); + Resize_Chunks (Data, Size, Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + if Low > 1 then + Move (Data.all, 1, Source.Data.all, 1, Low - 1); + end if; + if By'Length > 0 then + Move (Data.all, By, Low, Source.Chunk_Size); + end if; + if Hi < Source.Size then + Move (Data.all, Low + By'Length, Source.Data.all, Hi + 1, + Source.Size - Hi); + end if; + + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Source.Chunk_Size, + Allocation_Unit => Source.Allocation_Unit, + Size => Size, + Data => Data); + end Replace_Slice; + + + + procedure Replace_Slice (Source : in out Chunked_String; + Low : in Positive; + High : in Natural; + By : in String) + is + Size : Natural := 0; + Hi : Natural := High; + begin + if Low > Source.Size + 1 then + raise Ada.Strings.Index_Error; + end if; + + if High < Low then + Hi := Low - 1; + end if; + + Size := (Low - 1) + By'Length + (Source.Size - Hi); + Resize_Chunks (Source.Data, Size, + Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + if Hi < Source.Size and Low + By'Length /= Hi + 1 then + Move (Data => Source.Data.all, + Target_Position => Low + By'Length, + Source_Position => Hi + 1, + Length => Source.Size - Hi, + Chunk_Size => Source.Chunk_Size); + end if; + if By'Length > 0 then + Move (Source.Data.all, By, Low, Source.Chunk_Size); + end if; + Source.Size := Size; + end Replace_Slice; + + + + function Insert (Source : in Chunked_String; + Before : in Positive; + New_Item : in String) + return Chunked_String is + begin + return Replace_Slice (Source, Before, Before - 1, New_Item); + end Insert; + + + + procedure Insert (Source : in out Chunked_String; + Before : in Positive; + New_Item : in String) is + begin + Replace_Slice (Source, Before, Before - 1, New_Item); + end Insert; + + + + function Overwrite (Source : in Chunked_String; + Position : in Positive; + New_Item : in String) + return Chunked_String is + begin + return Replace_Slice (Source, Position, Source.Size, New_Item); + end Overwrite; + + + + procedure Overwrite (Source : in out Chunked_String; + Position : in Positive; + New_Item : in String) is + begin + Replace_Slice (Source, + Low => Position, + High => Natural'Min (Source.Size, + Position + New_Item'Length - 1), + By => New_Item); + end Overwrite; + + + + function Delete (Source : in Chunked_String; + From : in Positive; + Through : in Natural) + return Chunked_String is + begin + if From <= Through then + return Replace_Slice (Source, From, Through, ""); + else + return Duplicate (Source); + end if; + end Delete; + + + + procedure Delete (Source : in out Chunked_String; + From : in Positive; + Through : in Natural) is + begin + if From <= Through then + Replace_Slice (Source, From, Through, ""); + end if; + end Delete; + + + + function Trim (Source : in Chunked_String; + Side : in Ada.Strings.Trim_End) + return Chunked_String is + begin + case Side is + when Ada.Strings.Left => + return Trim (Source, + Maps.To_Set (Ada.Strings.Space), + Maps.Null_Set); + when Ada.Strings.Right => + return Trim (Source, + Maps.Null_Set, + Maps.To_Set (Ada.Strings.Space)); + when Ada.Strings.Both => + return Trim (Source, + Maps.To_Set (Ada.Strings.Space), + Maps.To_Set (Ada.Strings.Space)); + end case; + end Trim; + + + + procedure Trim (Source : in out Chunked_String; + Side : in Ada.Strings.Trim_End) is + begin + case Side is + when Ada.Strings.Left => + Trim (Source, + Maps.To_Set (Ada.Strings.Space), + Maps.Null_Set); + when Ada.Strings.Right => + Trim (Source, + Maps.Null_Set, + Maps.To_Set (Ada.Strings.Space)); + when Ada.Strings.Both => + Trim (Source, + Maps.To_Set (Ada.Strings.Space), + Maps.To_Set (Ada.Strings.Space)); + end case; + end Trim; + + + + procedure Trim_Bounds (Source : in Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set; + Low : out Positive; + High : out Natural) + is + Chunk : Positive; + begin + Low := 1; + High := Source.Size; + + Chunk := 1; + while Low <= High and then + Maps.Is_In (Source.Data (Chunk).all + (Low - (Chunk - 1) * Source.Chunk_Size), + Left) + loop + Low := Low + 1; + if Low mod Source.Chunk_Size = 1 then + Chunk := Chunk + 1; + end if; + end loop; + + if High > 0 then + Chunk := (High - 1) / Source.Chunk_Size + 1; + while Low <= High and then + Maps.Is_In (Source.Data (Chunk).all + (High - (Chunk - 1) * Source.Chunk_Size), + Right) + loop + High := High - 1; + if High mod Source.Chunk_Size = 0 then + Chunk := Chunk - 1; + end if; + end loop; + end if; + end Trim_Bounds; + + + + function Trim (Source : in Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set) + return Chunked_String + is + Low : Positive; + High : Natural; + begin + Trim_Bounds (Source, Left, Right, Low, High); + return Chunked_Slice (Source, Low, High, + Source.Chunk_Size, Source.Allocation_Unit); + end Trim; + + + + procedure Trim (Source : in out Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set) + is + Low : Positive; + High : Natural; + begin + Trim_Bounds (Source, Left, Right, Low, High); + if Low > 1 then + Move (Data => Source.Data.all, + Target_Position => 1, + Source_Position => Low, + Length => High - Low + 1, + Chunk_Size => Source.Chunk_Size); + end if; + Source.Size := High - Low + 1; + end Trim; + + + + function Head (Source : in Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space; + Chunk_Size : in Natural := 0; -- use value from Source + Allocation_Unit : in Natural := 0) -- use value from Source + return Chunked_String + is + Real_Chunk_Size : Positive := Default_Chunk_Size; + Real_Unit : Positive := Default_Allocation_Unit; + Data : Chunk_Array_Access := null; + begin + if Chunk_Size > 0 then + Real_Chunk_Size := Chunk_Size; + end if; + if Allocation_Unit > 0 then + Real_Unit := Allocation_Unit; + end if; + + if Count > 0 then + Resize_Chunks (Data, Count, Real_Chunk_Size, Real_Unit); + if Count > Source.Size then + Move (Data.all, 1, Source.Data.all, 1, Source.Size); + Fill (Data.all, Source.Size + 1, + Count - Source.Size, Pad, Real_Chunk_Size); + else + Move (Data.all, 1, Source.Data.all, 1, Count); + end if; + end if; + + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Real_Chunk_Size, + Allocation_Unit => Real_Unit, + Size => Count, + Data => Data); + end Head; + + + + procedure Head (Source : in out Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space) is + begin + if Count > Source.Size then + Resize_Chunks (Source.Data, Count, + Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + Fill (Source.Data.all, Source.Size + 1, Count - Source.Size, Pad, + Source.Chunk_Size); + end if; + Source.Size := Count; + end Head; + + + + function Tail (Source : in Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space; + Chunk_Size : in Natural := 0; -- use value from Source + Allocation_Unit : in Natural := 0) -- use value from Source + return Chunked_String + is + Real_Chunk_Size : Positive := Default_Chunk_Size; + Real_Unit : Positive := Default_Allocation_Unit; + Data : Chunk_Array_Access := null; + begin + if Chunk_Size > 0 then + Real_Chunk_Size := Chunk_Size; + end if; + if Allocation_Unit > 0 then + Real_Unit := Allocation_Unit; + end if; + + if Count > 0 then + Resize_Chunks (Data, Count, Real_Chunk_Size, Real_Unit); + if Count > Source.Size then + Fill (Data.all, 1, Count - Source.Size, Pad, Real_Chunk_Size); + Move (Data.all, Count - Source.Size + 1, + Source.Data.all, 1, Source.Size); + else + Move (Data.all, 1, + Source.Data.all, Source.Size - Count + 1, Count); + end if; + end if; + + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Real_Chunk_Size, + Allocation_Unit => Real_Unit, + Size => Count, + Data => Data); + end Tail; + + + + procedure Tail (Source : in out Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space) is + begin + Resize_Chunks (Source.Data, Count, + Source.Chunk_Size, Source.Allocation_Unit, + Can_Shrink => False); + if Count > Source.Size then + if Source.Size > 0 then + Move (Data => Source.Data.all, + Target_Position => Count - Source.Size + 1, + Source_Position => 1, + Length => Source.Size, + Chunk_Size => Source.Chunk_Size); + end if; + Fill (Source.Data.all, 1, Count - Source.Size, Pad, + Source.Chunk_Size); + elsif Count > 0 then + Move (Data => Source.Data.all, + Target_Position => 1, + Source_Position => Source.Size - Count + 1, + Length => Count, + Chunk_Size => Source.Chunk_Size); + end if; + Source.Size := Count; + end Tail; + + + + function "*" (Left : in Natural; + Right : in Character) + return Chunked_String + is + Chunk_Size : constant Positive := Default_Chunk_Size; + Allocation_Unit : constant Positive := Default_Allocation_Unit; + Size : constant Natural := Left; + Chunk_Nb : constant Natural + := Chunks_For (Size, Chunk_Size, Allocation_Unit); + Last_Chunk_Size : constant Natural + := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; + Data : Chunk_Array_Access := null; + begin + if Size > 0 then + Data := new Chunk_Array (1 .. Chunk_Nb); + for J in 1 .. Chunk_Nb - 1 loop + Data (J) := new String'(Ada.Strings.Fixed."*" (Chunk_Size, Right)); + end loop; + Data (Chunk_Nb) := new + String'(Ada.Strings.Fixed."*" (Last_Chunk_Size, Right)); + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Size, + Data => Data); + end "*"; + + + + function "*" (Left : in Natural; + Right : in String) + return Chunked_String + is + Chunk_Size : constant Positive := Default_Chunk_Size; + Allocation_Unit : constant Positive := Default_Allocation_Unit; + Size : constant Natural := Left * Right'Length; + Chunk_Nb : constant Natural + := Chunks_For (Size, Chunk_Size, Allocation_Unit); + Last_Chunk_Size : constant Natural + := Units_For (Size, Chunk_Size, Allocation_Unit) * Allocation_Unit; + Data : Chunk_Array_Access := null; + begin + if Size > 0 then + if Chunk_Size mod Right'Length = 0 then + Data := new Chunk_Array (1 .. Chunk_Nb); + for J in 1 .. Chunk_Nb - 1 loop + Data (J) := new String'(Ada.Strings.Fixed."*" + (Chunk_Size / Right'Length, Right)); + end loop; + Data (Chunk_Nb) := new String'(Ada.Strings.Fixed."*" + (Last_Chunk_Size / Right'Length, Right)); + else + Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); + for J in 1 .. Left loop + Move (Data.all, Right, (J - 1) * Right'Length + 1, Chunk_Size); + end loop; + end if; + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Size, + Data => Data); + end "*"; + + + + function "*" (Left : in Natural; + Right : in Chunked_String) + return Chunked_String + is + Chunk_Size : constant Positive := Default_Chunk_Size; + Allocation_Unit : constant Positive := Default_Allocation_Unit; + Size : constant Natural := Left * Right.Size; + Data : Chunk_Array_Access := null; + begin + if Size > 0 then + Resize_Chunks (Data, Size, Chunk_Size, Allocation_Unit); + for J in 1 .. Left loop + Move (Data.all, (J - 1) * Right.Size + 1, + Right.Data.all, 1, Right.Size); + end loop; + end if; + return Chunked_String'(Ada.Finalization.Controlled with + Chunk_Size => Chunk_Size, + Allocation_Unit => Allocation_Unit, + Size => Size, + Data => Data); + end "*"; + + + + -- Controlled object methods + + overriding procedure Initialize (Object : in out Chunked_String) is + begin + Object.Size := 0; + Object.Data := null; + end Initialize; + + + + overriding procedure Adjust (Object : in out Chunked_String) is + New_Data : Chunk_Array_Access; + begin + if Object.Data /= null then + New_Data := new Chunk_Array (Object.Data'Range); + for J in Object.Data'Range loop + New_Data (J) := new String'(Object.Data (J).all); + end loop; + Object.Data := New_Data; + end if; + end Adjust; + + + + overriding procedure Finalize (Object : in out Chunked_String) is + begin + Free (Object.Data); + end Finalize; + +end Natools.Chunked_Strings; ADDED src/natools-chunked_strings.ads Index: src/natools-chunked_strings.ads ================================================================== --- src/natools-chunked_strings.ads +++ src/natools-chunked_strings.ads @@ -0,0 +1,433 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings is a string container designed for large amount -- +-- of data and efficient accumulation (append). Most subprograms are the -- +-- direct copy of Unbounded_String equivalent from LRM, with the same -- +-- semantics. -- +-- -- +-- The implementation uses fixed-size "chunks" of memory, so that large -- +-- strings do not have to be stored in a contiguous space. This also allows -- +-- more efficient appends, since only the last chunk might need dynamic -- +-- resize. -- +-- Moreover the last chunk is constrained to have a size multiple of -- +-- Allocation_Unit, so if Allocation_Unit = Chunk_Size, no string resize -- +-- ever happen. -- +-- -- +-- The list of chunks is stored as a usual dynamic array, so append -- +-- operations are still linear (when a new chunk has to be created), they -- +-- are just O(Size / Chunk_Size) instead of O(Size). For suitable values of -- +-- Chunk_Size, that should be a significant improuvement. -- +-- -- +-- Chunk_Size and Allocation_Unit are defined per Chunked_String, which -- +-- allows to use suitable parameters depending on the expected string size. -- +-- Generic parameters control the default values, e.g. in operations like -- +-- "&" which don't allow to specify them. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; +with Natools.Accumulators; + +private with Ada.Finalization; + +generic + Default_Allocation_Unit : Positive := 64; + Default_Chunk_Size : Positive := 4096; + +package Natools.Chunked_Strings is + pragma Preelaborate (Chunked_Strings); + + package Maps renames Ada.Strings.Maps; + + type Chunked_String is new Natools.Accumulators.String_Accumulator + with private; + + function Build (Depth : Positive) + return Natools.Accumulators.String_Accumulator'Class; + -- Returns a new empty chunked string + -- Ignores its Depth argument + -- Can be used with Natools.Accumulators.String_Accumulator_Linked_Lists + + function Duplicate (Source : in Chunked_String) return Chunked_String; + -- returns a copy of the given chunked string + + procedure Free_Extra_Memory (From : in out Chunked_String); + -- Release as much memory as possible without altering the contents + + procedure Hard_Reset (Str : in out Chunked_String); + -- Empty the string and free all possible memory + + procedure Preallocate (Str : in out Chunked_String; Size : Natural); + -- Allocate enough memory to reach Size without subsequent reallocation + + procedure Soft_Reset (Str : in out Chunked_String); + -- Empty the string for reuse + + procedure To_String (Source : Chunked_String; Output : out String); + -- Write the contents of the chunked string into the output string, + -- which must be large enough. + + + ------------------------------------------- + -- String_Accumulator specific interface -- + ------------------------------------------- + + -- Append, Length and To_String are part of the standard interface + -- Hard_Reset and Soft_Reset are already in the specific interface + + function Tail (Source : in Chunked_String; Size : in Natural) return String; + + procedure Unappend (From : in out Chunked_String; Text : in String); + + + ------------------------ + -- Standard interface -- + ------------------------ + + -- All the following declarations are copied from Unbounded_String + -- interface and have exactly the same semantics. + -- Subprogram that create new Chunked_String objects also have + -- Chunk_Size and Allocation_Unit optional parameters. + + Null_Chunked_String : constant Chunked_String; + + function Length (Source : in Chunked_String) return Natural; + + type String_Access is access all String; + procedure Free (X : in out String_Access); + + -- Conversion, Concatenation, and Selection functions + + function To_Chunked_String + (Source : in String; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String; + + function To_Chunked_String + (Length : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String; + + function To_String (Source : in Chunked_String) return String; + + procedure Set_Chunked_String + (Target : out Chunked_String; + Source : in String; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit); + + procedure Append (Source : in out Chunked_String; + New_Item : in Chunked_String); + + procedure Append (Source : in out Chunked_String; + New_Item : in String); + + procedure Append (Source : in out Chunked_String; + New_Item : in Character); + + function "&" (Left, Right : in Chunked_String) + return Chunked_String; + + function "&" (Left : in Chunked_String; Right : in String) + return Chunked_String; + + function "&" (Left : in String; Right : in Chunked_String) + return Chunked_String; + + function "&" (Left : in Chunked_String; Right : in Character) + return Chunked_String; + + function "&" (Left : in Character; Right : in Chunked_String) + return Chunked_String; + + function Element (Source : in Chunked_String; + Index : in Positive) + return Character; + pragma Inline (Element); + + procedure Replace_Element (Source : in out Chunked_String; + Index : in Positive; + By : in Character); + + function Slice (Source : in Chunked_String; + Low : in Positive; + High : in Natural) + return String; + + function Chunked_Slice + (Source : in Chunked_String; + Low : in Positive; + High : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit) + return Chunked_String; + + procedure Chunked_Slice + (Source : in Chunked_String; + Target : out Chunked_String; + Low : in Positive; + High : in Natural; + Chunk_Size : in Positive := Default_Chunk_Size; + Allocation_Unit : in Positive := Default_Allocation_Unit); + + function "=" (Left, Right : in Chunked_String) return Boolean; + + function "=" (Left : in Chunked_String; Right : in String) + return Boolean; + + function "=" (Left : in String; Right : in Chunked_String) + return Boolean; + + function "<" (Left, Right : in Chunked_String) return Boolean; + + function "<" (Left : in Chunked_String; Right : in String) + return Boolean; + + function "<" (Left : in String; Right : in Chunked_String) + return Boolean; + + function "<=" (Left, Right : in Chunked_String) return Boolean; + + function "<=" (Left : in Chunked_String; Right : in String) + return Boolean; + + function "<=" (Left : in String; Right : in Chunked_String) + return Boolean; + + function ">" (Left, Right : in Chunked_String) return Boolean; + + function ">" (Left : in Chunked_String; Right : in String) + return Boolean; + + function ">" (Left : in String; Right : in Chunked_String) + return Boolean; + + function ">=" (Left, Right : in Chunked_String) return Boolean; + + function ">=" (Left : in Chunked_String; Right : in String) + return Boolean; + + function ">=" (Left : in String; Right : in Chunked_String) + return Boolean; + + function Index (Source : in Chunked_String; + Pattern : in String; + From : in Positive; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Index (Source : in Chunked_String; + Pattern : in String; + From : in Positive; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping_Function) + return Natural; + + function Index (Source : in Chunked_String; + Pattern : in String; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Index (Source : in Chunked_String; + Pattern : in String; + Going : in Ada.Strings.Direction := Ada.Strings.Forward; + Mapping : in Maps.Character_Mapping_Function) + return Natural; + + function Index (Source : in Chunked_String; + Set : in Maps.Character_Set; + From : in Positive; + Test : in Ada.Strings.Membership := Ada.Strings.Inside; + Going : in Ada.Strings.Direction := Ada.Strings.Forward) + return Natural; + + function Index (Source : in Chunked_String; + Set : in Maps.Character_Set; + Test : in Ada.Strings.Membership := Ada.Strings.Inside; + Going : in Ada.Strings.Direction := Ada.Strings.Forward) + return Natural; + + function Index_Non_Blank (Source : in Chunked_String; + From : in Positive; + Going : in Ada.Strings.Direction + := Ada.Strings.Forward) + return Natural; + + function Index_Non_Blank (Source : in Chunked_String; + Going : in Ada.Strings.Direction + := Ada.Strings.Forward) + return Natural; + + function Count (Source : in Chunked_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping := Maps.Identity) + return Natural; + + function Count (Source : in Chunked_String; + Pattern : in String; + Mapping : in Maps.Character_Mapping_Function) + return Natural; + + function Count (Source : in Chunked_String; + Set : in Maps.Character_Set) + return Natural; + + procedure Find_Token (Source : in Chunked_String; + Set : in Maps.Character_Set; + Test : in Ada.Strings.Membership; + First : out Positive; + Last : out Natural); + + -- String translation subprograms + + function Translate (Source : in Chunked_String; + Mapping : in Maps.Character_Mapping) + return Chunked_String; + + procedure Translate (Source : in out Chunked_String; + Mapping : in Maps.Character_Mapping); + + function Translate (Source : in Chunked_String; + Mapping : in Maps.Character_Mapping_Function) + return Chunked_String; + + procedure Translate (Source : in out Chunked_String; + Mapping : in Maps.Character_Mapping_Function); + + -- String transformation subprograms + + function Replace_Slice (Source : in Chunked_String; + Low : in Positive; + High : in Natural; + By : in String) + return Chunked_String; + + procedure Replace_Slice (Source : in out Chunked_String; + Low : in Positive; + High : in Natural; + By : in String); + + function Insert (Source : in Chunked_String; + Before : in Positive; + New_Item : in String) + return Chunked_String; + + procedure Insert (Source : in out Chunked_String; + Before : in Positive; + New_Item : in String); + + function Overwrite (Source : in Chunked_String; + Position : in Positive; + New_Item : in String) + return Chunked_String; + + procedure Overwrite (Source : in out Chunked_String; + Position : in Positive; + New_Item : in String); + + function Delete (Source : in Chunked_String; + From : in Positive; + Through : in Natural) + return Chunked_String; + + procedure Delete (Source : in out Chunked_String; + From : in Positive; + Through : in Natural); + + function Trim (Source : in Chunked_String; + Side : in Ada.Strings.Trim_End) + return Chunked_String; + + procedure Trim (Source : in out Chunked_String; + Side : in Ada.Strings.Trim_End); + + function Trim (Source : in Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set) + return Chunked_String; + + procedure Trim (Source : in out Chunked_String; + Left : in Maps.Character_Set; + Right : in Maps.Character_Set); + + function Head (Source : in Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space; + Chunk_Size : in Natural := 0; -- use value from Source + Allocation_Unit : in Natural := 0) -- use value from Source + return Chunked_String; + + procedure Head (Source : in out Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space); + + function Tail (Source : in Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space; + Chunk_Size : in Natural := 0; -- use value from Source + Allocation_Unit : in Natural := 0) -- use value from Source + return Chunked_String; + + procedure Tail (Source : in out Chunked_String; + Count : in Natural; + Pad : in Character := Ada.Strings.Space); + + function "*" (Left : in Natural; + Right : in Character) + return Chunked_String; + + function "*" (Left : in Natural; + Right : in String) + return Chunked_String; + + function "*" (Left : in Natural; + Right : in Chunked_String) + return Chunked_String; + +private + type Chunk_Array is array (Positive range <>) of String_Access; + type Chunk_Array_Access is access all Chunk_Array; + + type Chunked_String is new Ada.Finalization.Controlled + and Natools.Accumulators.String_Accumulator + with record + Chunk_Size : Positive := Default_Chunk_Size; + Allocation_Unit : Positive := Default_Allocation_Unit; + Size : Natural := 0; + Data : Chunk_Array_Access := null; + end record; + + overriding procedure Initialize (Object : in out Chunked_String); + overriding procedure Adjust (Object : in out Chunked_String); + overriding procedure Finalize (Object : in out Chunked_String); + -- Controlled type methods + + function Is_Valid (Source : in Chunked_String) return Boolean; + -- Internal consistency checks + + Null_Chunked_String : constant Chunked_String := + (Ada.Finalization.Controlled with + Chunk_Size => Default_Chunk_Size, + Allocation_Unit => Default_Allocation_Unit, + Size => 0, + Data => null); + +end Natools.Chunked_Strings; ADDED src/natools-getopt_long.adb Index: src/natools-getopt_long.adb ================================================================== --- src/natools-getopt_long.adb +++ src/natools-getopt_long.adb @@ -0,0 +1,670 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Maps; + +package body Natools.Getopt_Long is + + package Fixed renames Ada.Strings.Fixed; + package Maps renames Ada.Strings.Maps; + + + --------------------------- + -- Any_Name constructors -- + --------------------------- + + function To_Name (Long_Name : String) return Any_Name is + begin + return Any_Name'(Style => Long, + Size => Long_Name'Length, + Long => Long_Name); + end To_Name; + + + function To_Name (Short_Name : Character) return Any_Name is + begin + return Any_Name'(Style => Short, Size => 1, Short => Short_Name); + end To_Name; + + + function Image (Name : Any_Name) return String is + begin + case Name.Style is + when Short => return '-' & Name.Short; + when Long => return "--" & Name.Long; + end case; +-- Alternate implementation: +-- case Name.Style is +-- when Short => return String'(1 => Name.Short); +-- when Long => return '"' & Name.Long & '"'; +-- end case; + end Image; + + + + ---------------------- + -- Default handlers -- + ---------------------- + + package body Handlers is + + procedure Missing_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name) + is + pragma Unreferenced (Handler); + pragma Unreferenced (Id); + begin + raise Option_Error with + "Missing argument to option " & Image (Name); + end Missing_Argument; + + + procedure Unexpected_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name; + Argument : String) + is + pragma Unreferenced (Handler); + pragma Unreferenced (Id); + begin + raise Option_Error with + "Unexpected argument """ & Argument + & """ to option " & Image (Name); + end Unexpected_Argument; + + + procedure Unknown_Option + (Handler : in out Callback; + Name : Any_Name) + is + pragma Unreferenced (Handler); + begin + raise Option_Error with "Unknown option " & Image (Name); + end Unknown_Option; + + end Handlers; + + + + ------------------------------------- + -- Simple configuration parameters -- + ------------------------------------- + + function Posixly_Correct (Config : Configuration) return Boolean is + begin + return Config.Posixly_Correct; + end Posixly_Correct; + + + procedure Posixly_Correct + (Config : in out Configuration; + To : Boolean := True) is + begin + Config.Posixly_Correct := To; + end Posixly_Correct; + + + function Long_Only (Config : Configuration) return Boolean is + begin + return Config.Long_Only; + end Long_Only; + + + procedure Use_Long_Only + (Config : in out Configuration; + Value : Boolean := True) is + begin + Config.Long_Only := Value; + end Use_Long_Only; + + + + ---------------------------- + -- Option list management -- + ---------------------------- + + procedure Add_Option + (Config : in out Configuration; + Long_Name : String; + Short_Name : Character; + Has_Arg : Argument_Requirement; + Id : Option_Id) + is + New_Option : constant Option + := (Long_Name_Length => Long_Name'Length, + Id => Id, + Has_Arg => Has_Arg, + Long_Name => Long_Name, + Short_Name => Short_Name); + begin + if Long_Name = Null_Long_Name or Short_Name = Null_Short_Name then + raise Constraint_Error; + end if; + Config.By_Long_Name.Insert (Long_Name, New_Option); + Config.By_Short_Name.Insert (Short_Name, New_Option); + end Add_Option; + + + procedure Add_Option + (Config : in out Configuration; + Long_Name : String; + Has_Arg : Argument_Requirement; + Id : Option_Id) + is + New_Option : constant Option + := (Long_Name_Length => Long_Name'Length, + Id => Id, + Has_Arg => Has_Arg, + Long_Name => Long_Name, + Short_Name => Null_Short_Name); + begin + if Long_Name = Null_Long_Name then + raise Constraint_Error; + end if; + Config.By_Long_Name.Insert (Long_Name, New_Option); + end Add_Option; + + + procedure Add_Option + (Config : in out Configuration; + Short_Name : Character; + Has_Arg : Argument_Requirement; + Id : Option_Id) + is + New_Option : constant Option + := (Long_Name_Length => 0, + Id => Id, + Has_Arg => Has_Arg, + Long_Name => Null_Long_Name, + Short_Name => Short_Name); + begin + if Short_Name = Null_Short_Name then + raise Constraint_Error; + end if; + Config.By_Short_Name.Insert (Short_Name, New_Option); + end Add_Option; + + + procedure Del_Option + (Config : in out Configuration; + Id : Option_Id) + is + Short_Name_Cursor : Short_Option_Maps.Cursor + := Config.By_Short_Name.First; + Long_Name_Cursor : Long_Option_Maps.Cursor + := Config.By_Long_Name.First; + begin + while Short_Option_Maps.Has_Element (Short_Name_Cursor) loop + declare + Next : constant Short_Option_Maps.Cursor + := Short_Option_Maps.Next (Short_Name_Cursor); + begin + if Short_Option_Maps.Element (Short_Name_Cursor).Id = Id then + Config.By_Short_Name.Delete (Short_Name_Cursor); + end if; + Short_Name_Cursor := Next; + end; + end loop; + while Long_Option_Maps.Has_Element (Long_Name_Cursor) loop + declare + Next : constant Long_Option_Maps.Cursor + := Long_Option_Maps.Next (Long_Name_Cursor); + begin + if Long_Option_Maps.Element (Long_Name_Cursor).Id = Id then + Config.By_Long_Name.Delete (Long_Name_Cursor); + end if; + Long_Name_Cursor := Next; + end; + end loop; + end Del_Option; + + + procedure Del_Option + (Config : in out Configuration; + Long_Name : String) is + begin + Config.By_Long_Name.Delete (Long_Name); + end Del_Option; + + + procedure Del_Option + (Config : in out Configuration; + Short_Name : Character) is + begin + Config.By_Short_Name.Delete (Short_Name); + end Del_Option; + + + + ---------------------------- + -- Formatting subprograms -- + ---------------------------- + + function Format_Long_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Name_Prefix : String := "--") + return String + is + Long_Name_Count : constant Natural := Get_Long_Name_Count (Config, Id); + Space_Per_Name : constant Positive + := Name_Prefix'Length + 1 + Separator'Length; + Result : String (1 .. Long_Name_Count * Space_Per_Name); + begin + if Long_Name_Count = 0 then + return ""; + end if; + for J in 1 .. Long_Name_Count loop + declare + First : constant Positive + := Result'First + (J - 1) * Space_Per_Name; + Name : constant String := Get_Long_Name (Config, Id, J); + begin + Result (First .. First + Name_Prefix'Length - 1) := Name_Prefix; + Result (First + Name_Prefix'Length .. + First + Name_Prefix'Length + Name'Length - 1) + := Name; + Result (First + Name_Prefix'Length + Name'Length .. + First + Space_Per_Name - 1) + := Separator; + end; + end loop; + return Result (1 .. Long_Name_Count * Space_Per_Name - Separator'Length); + end Format_Long_Names; + + + function Format_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Long_Name_Prefix : String := "--"; + Short_Name_Prefix : String := "-"; + Short_First : Boolean := True) + return String + is + Long_Names : constant String + := Format_Long_Names (Config, Id, Separator, Long_Name_Prefix); + Short_Names : constant String + := Format_Short_Names (Config, Id, Separator, Short_Name_Prefix); + begin + if Long_Names = "" then + return Short_Names; + elsif Short_Names = "" then + return Long_Names; + elsif Short_First then + return Short_Names & Separator & Long_Names; + else + return Long_Names & Separator & Short_Names; + end if; + end Format_Names; + + + function Format_Short_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Name_Prefix : String := "-") + return String + is + Short_Names : constant String := Get_Short_Names (Config, Id); + Space_Per_Name : constant Positive + := Name_Prefix'Length + 1 + Separator'Length; + Result : String (1 .. Short_Names'Length * Space_Per_Name); + begin + if Short_Names = "" then + return ""; + end if; + for J in Short_Names'Range loop + declare + First : constant Positive + := Result'First + (J - Short_Names'First) * Space_Per_Name; + begin + Result (First .. First + Name_Prefix'Length - 1) := Name_Prefix; + Result (First + Name_Prefix'Length) := Short_Names (J); + Result (First + Name_Prefix'Length + 1 .. + First + Space_Per_Name - 1) := Separator; + end; + end loop; + return Result (Result'First .. Result'Last - Separator'Length); + end Format_Short_Names; + + + + function Get_Long_Name + (Config : Configuration; + Id : Option_Id; + Index : Positive := 1) + return String + is + Seen : Natural := 0; + Cursor : Long_Option_Maps.Cursor := Config.By_Long_Name.First; + begin + while Long_Option_Maps.Has_Element (Cursor) loop + declare + Opt : constant Option := Long_Option_Maps.Element (Cursor); + begin + if Opt.Id = Id then + Seen := Seen + 1; + if Seen = Index then + return Opt.Long_Name; + end if; + end if; + end; + Long_Option_Maps.Next (Cursor); + end loop; + raise Constraint_Error; + end Get_Long_Name; + + + function Get_Long_Name_Count + (Config : Configuration; + Id : Option_Id) + return Natural + is + procedure Process (Key : String; Element : Option); + procedure Process (Cursor : Long_Option_Maps.Cursor); + + Result : Natural := 0; + + procedure Process (Key : String; Element : Option) is + pragma Unreferenced (Key); + begin + if Element.Id = Id then + Result := Result + 1; + end if; + end Process; + + procedure Process (Cursor : Long_Option_Maps.Cursor) is + begin + Long_Option_Maps.Query_Element (Cursor, Process'Access); + end Process; + begin + Config.By_Long_Name.Iterate (Process'Access); + return Result; + end Get_Long_Name_Count; + + + function Get_Short_Name_Count + (Config : Configuration; + Id : Option_Id) + return Natural + is + procedure Process (Key : Character; Element : Option); + procedure Process (Cursor : Short_Option_Maps.Cursor); + + Result : Natural := 0; + + procedure Process (Key : Character; Element : Option) is + pragma Unreferenced (Key); + begin + if Element.Id = Id then + Result := Result + 1; + end if; + end Process; + + procedure Process (Cursor : Short_Option_Maps.Cursor) is + begin + Short_Option_Maps.Query_Element (Cursor, Process'Access); + end Process; + begin + Config.By_Short_Name.Iterate (Process'Access); + return Result; + end Get_Short_Name_Count; + + + function Get_Short_Names + (Config : Configuration; + Id : Option_Id) + return String + is + procedure Process (Key : Character; Element : Option); + procedure Process (Cursor : Short_Option_Maps.Cursor); + + Result : String (1 .. Config.Get_Short_Name_Count (Id)); + J : Positive := Result'First; + + procedure Process (Key : Character; Element : Option) is + begin + if Element.Id = Id then + Result (J) := Key; + J := J + 1; + end if; + end Process; + + procedure Process (Cursor : Short_Option_Maps.Cursor) is + begin + Short_Option_Maps.Query_Element (Cursor, Process'Access); + end Process; + begin + Config.By_Short_Name.Iterate (Process'Access); + return Result; + end Get_Short_Names; + + + procedure Iterate + (Config : Configuration; + Process : not null access procedure (Id : Option_Id; + Long_Name : String; + Short_Name : Character; + Has_Arg : Argument_Requirement)) + is + procedure Long_Process (Key : String; Opt : Option); + procedure Long_Query (C : Long_Option_Maps.Cursor); + procedure Short_Process (Key : Character; Opt : Option); + procedure Short_Query (C : Short_Option_Maps.Cursor); + + procedure Long_Process (Key : String; Opt : Option) is + pragma Unreferenced (Key); + begin + if Opt.Short_Name = Null_Short_Name then + Process (Opt.Id, Opt.Long_Name, Opt.Short_Name, Opt.Has_Arg); + end if; + end Long_Process; + + procedure Long_Query (C : Long_Option_Maps.Cursor) is + begin + Long_Option_Maps.Query_Element (C, Long_Process'Access); + end Long_Query; + + procedure Short_Process (Key : Character; Opt : Option) is + pragma Unreferenced (Key); + begin + Process (Opt.Id, Opt.Long_Name, Opt.Short_Name, Opt.Has_Arg); + end Short_Process; + + procedure Short_Query (C : Short_Option_Maps.Cursor) is + begin + Short_Option_Maps.Query_Element (C, Short_Process'Access); + end Short_Query; + begin + Config.By_Short_Name.Iterate (Short_Query'Access); + Config.By_Long_Name.Iterate (Long_Query'Access); + end Iterate; + + + + ----------------------------- + -- Command-line processing -- + ----------------------------- + + procedure Process + (Config : Configuration; + Handler : in out Handlers.Callback'Class; + Argument_Count : not null access function return Natural + := Ada.Command_Line.Argument_Count'Access; + Argument : not null access function (Number : Positive) return String + := Ada.Command_Line.Argument'Access) + is + procedure Process_Long_Option (Arg : String); + + Arg_Count : constant Natural := Argument_Count.all; + Arg_N : Positive := 1; + + procedure Process_Long_Option (Arg : String) is + function Has_Prefix (C : Long_Option_Maps.Cursor; Prefix : String) + return Boolean; + + Equal : constant Natural := Fixed.Index (Arg, Maps.To_Set ('=')); + Cursor : Long_Option_Maps.Cursor; + Arg_Name_Last : Natural := Arg'Last; + + function Has_Prefix (C : Long_Option_Maps.Cursor; Prefix : String) + return Boolean + is + Key : constant String := Long_Option_Maps.Key (C); + begin + return Key'Length >= Prefix'Length and then + Key (1 .. Prefix'Length) = Prefix; + end Has_Prefix; + begin + if Equal /= 0 then + Arg_Name_Last := Equal - 1; + end if; + declare + Arg_Name : String renames Arg (Arg'First .. Arg_Name_Last); + begin + -- Looking for an exact match + Cursor := Config.By_Long_Name.Find (Arg_Name); + if not Long_Option_Maps.Has_Element (Cursor) then + -- Looking for a unique partial match + Cursor := Config.By_Long_Name.Ceiling (Arg_Name); + if not Long_Option_Maps.Has_Element (Cursor) or else + not Has_Prefix (Cursor, Arg_Name) or else + Has_Prefix (Long_Option_Maps.Next (Cursor), Arg_Name) + then + Handler.Unknown_Option (To_Name (Arg_Name)); + return; + end if; + end if; + -- At this point, Cursor points to the selected argument + declare + Opt : constant Option := Long_Option_Maps.Element (Cursor); + begin + case Opt.Has_Arg is + when No_Argument => + if Equal = 0 then + Handler.Option (Opt.Id, ""); + else + Handler.Unexpected_Argument + (Opt.Id, + To_Name (Opt.Long_Name), + Arg (Equal + 1 .. Arg'Last)); + end if; + when Optional_Argument => + if Equal = 0 then + Handler.Option (Opt.Id, ""); + else + Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); + end if; + when Required_Argument => + if Equal = 0 then + if Arg_N = Arg_Count then + Handler.Missing_Argument + (Opt.Id, To_Name (Opt.Long_Name)); + else + Handler.Option (Opt.Id, Argument (Arg_N + 1)); + Arg_N := Arg_N + 1; + end if; + else + Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); + end if; + end case; + end; + end; + end Process_Long_Option; + begin + while Arg_N <= Arg_Count loop + declare + Arg : constant String := Argument (Arg_N); + begin + if Arg'Length <= 1 or else Arg (Arg'First) /= '-' then + -- This is a non-flag argument, abort option processing if + -- posixly correct. + if Config.Posixly_Correct then + exit; + else + Handler.Argument (Arg); + Arg_N := Arg_N + 1; + end if; + elsif Arg (Arg'First + 1) = '-' then + -- "--" stops option processing. + if Arg'Length = 2 then + Arg_N := Arg_N + 1; + exit; + end if; + -- Argument starting with "--": long option. + Process_Long_Option (Arg (Arg'First + 2 .. Arg'Last)); + Arg_N := Arg_N + 1; + elsif Config.Long_Only then + -- Force long option on a single dash prefix. + Process_Long_Option (Arg (Arg'First + 1 .. Arg'Last)); + Arg_N := Arg_N + 1; + else + -- Process a list of short options, until one with required + -- argument is encountered (and the rest is its argument). + for Arg_I in Arg'First + 1 .. Arg'Last loop + declare + Cursor : constant Short_Option_Maps.Cursor + := Config.By_Short_Name.Find (Arg (Arg_I)); + begin + if Short_Option_Maps.Has_Element (Cursor) then + declare + Opt : constant Option + := Short_Option_Maps.Element (Cursor); + begin + if Opt.Has_Arg = Required_Argument then + if Arg_I = Arg'Last then + if Arg_N = Arg_Count then + Handler.Missing_Argument + (Opt.Id, To_Name (Opt.Short_Name)); + else + Handler.Option + (Opt.Id, Argument (Arg_N + 1)); + Arg_N := Arg_N + 1; + exit; + end if; + else + Handler.Option + (Opt.Id, Arg (Arg_I + 1 .. Arg'Last)); + exit; + end if; + else + Handler.Option (Opt.Id, ""); + end if; + end; + else + Handler.Unknown_Option (To_Name (Arg (Arg_I))); + end if; + end; + end loop; + Arg_N := Arg_N + 1; + end if; + end; + end loop; + + -- Only non-flag arguments remain + while Arg_N <= Arg_Count loop + Handler.Argument (Argument (Arg_N)); + Arg_N := Arg_N + 1; + end loop; + end Process; + +end Natools.Getopt_Long; ADDED src/natools-getopt_long.ads Index: src/natools-getopt_long.ads ================================================================== --- src/natools-getopt_long.ads +++ src/natools-getopt_long.ads @@ -0,0 +1,294 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Getopt_Long is a native Ada implementation of getopt_long() -- +-- processor for command line arguments. -- +-- -- +-- This package is generic, and its only formal parameter is a descrete -- +-- type supposed to cover all command-line options. -- +-- -- +-- Configuration objects hold the list of recognized options and parameters -- +-- about how to process them. Options can have a single-character short -- +-- name or a multiple-character long name. Moreover, there is no limit to -- +-- the number of flag names referring to the same Option_Id value. -- +-- -- +-- Once the Configuration object has been filled with flags recognized -- +-- by the client, the actual command-line arguments can be processed, -- +-- using the handler callbacks from a Handlers.Callback'Class object. -- +-- -- +-- Callback subprograms for normal operation are Option, for command-line -- +-- flags identified by their Option_Id, and Argument, for top-level command -- +-- line arguments. There are also callbacks for error conditions (missing -- +-- or unexpected argument, unknown option), whose implementation in -- +-- Handlers.Callback are simply to raise Option_Error with an appropriate -- +-- message. -- +------------------------------------------------------------------------------ + + +with Ada.Command_Line; +private with Ada.Containers.Indefinite_Ordered_Maps; + +generic + type Option_Id is (<>); + +package Natools.Getopt_Long is + pragma Preelaborate (Getopt_Long); + + Null_Long_Name : constant String := ""; + Null_Short_Name : constant Character := Character'Val (0); + + + + ------------------------------------------ + -- Holder for both short and long names -- + ------------------------------------------ + + type Name_Style is (Long, Short); + + type Any_Name (Style : Name_Style; Size : Positive) is record + case Style is + when Short => + Short : Character; + when Long => + Long : String (1 .. Size); + end case; + end record; + + function To_Name (Long_Name : String) return Any_Name; + function To_Name (Short_Name : Character) return Any_Name; + function Image (Name : Any_Name) return String; + + + + ------------------------ + -- Callback interface -- + ------------------------ + + Option_Error : exception; + + package Handlers is + + type Callback is abstract tagged null record; + + procedure Option + (Handler : in out Callback; + Id : Option_Id; + Argument : String) + is abstract; + -- Callback for successfully-parsed options. + + procedure Argument + (Handler : in out Callback; + Argument : String) + is abstract; + -- Callback for non-flag arguments. + + procedure Missing_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name); + -- Raise Option_Error (default error handler). + + procedure Unexpected_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name; + Argument : String); + -- Raise Option_Error (default error handler). + + procedure Unknown_Option + (Handler : in out Callback; + Name : Any_Name); + -- Raise Option_Error (default error handler). + + end Handlers; + + + + ---------------------------- + -- Configuration database -- + ---------------------------- + + type Argument_Requirement is + (No_Argument, Required_Argument, Optional_Argument); + + type Configuration is tagged private; + + + -- Simple parameters -- + + function Posixly_Correct (Config : Configuration) return Boolean; + + procedure Posixly_Correct + (Config : in out Configuration; + To : Boolean := True); + + function Long_Only (Config : Configuration) return Boolean; + + procedure Use_Long_Only + (Config : in out Configuration; + Value : Boolean := True); + + + -- Option list management -- + + procedure Add_Option + (Config : in out Configuration; + Long_Name : String; + Short_Name : Character; + Has_Arg : Argument_Requirement; + Id : Option_Id); + -- Add an option with both a short and a long name to the database. + + procedure Add_Option + (Config : in out Configuration; + Long_Name : String; + Has_Arg : Argument_Requirement; + Id : Option_Id); + -- Add an option with only a long name to the database. + + procedure Add_Option + (Config : in out Configuration; + Short_Name : Character; + Has_Arg : Argument_Requirement; + Id : Option_Id); + -- Add an option with only a short name to the database. + + procedure Del_Option + (Config : in out Configuration; + Id : Option_Id); + -- Remove from the database an option identified by its id. + + procedure Del_Option + (Config : in out Configuration; + Long_Name : String); + -- Remove from the database an option identified by its long name. + + procedure Del_Option + (Config : in out Configuration; + Short_Name : Character); + -- Remove from the database an option identified by its short name. + + + -- Formatting subprograms -- + + function Format_Long_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Name_Prefix : String := "--") + return String; + -- Return a human-readable list of long names for the given option. + + function Format_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Long_Name_Prefix : String := "--"; + Short_Name_Prefix : String := "-"; + Short_First : Boolean := True) + return String; + -- Return a human-readable list of all names for the given option. + + function Format_Short_Names + (Config : Configuration; + Id : Option_Id; + Separator : String := ", "; + Name_Prefix : String := "-") + return String; + -- Return a human-readable list of short names for the given option. + + function Get_Long_Name + (Config : Configuration; + Id : Option_Id; + Index : Positive := 1) + return String; + -- Return the "Index"th long name for the given option id. + -- Raise Constraint_Error when Index is not + -- in range 1 .. Get_Long_Name_Count (Config, Id) + + function Get_Long_Name_Count + (Config : Configuration; + Id : Option_Id) + return Natural; + -- Return the number of long names for the given option id. + + function Get_Short_Name_Count + (Config : Configuration; + Id : Option_Id) + return Natural; + -- Return the number of short names for the given option id. + + function Get_Short_Names + (Config : Configuration; + Id : Option_Id) + return String; + -- Return a string containing the characters for short names for + -- the given option id. + + procedure Iterate + (Config : Configuration; + Process : not null access procedure (Id : Option_Id; + Long_Name : String; + Short_Name : Character; + Has_Arg : Argument_Requirement)); + -- Iterate over all options, starting with options having a short name, + -- followed by options having only a long name, sorted respectively by + -- short and long name. + -- Process is called for each option; for options lacking a long name, + -- Long_Name is "", and for options lacking a short name, Short_Name + -- is Character'Val (0). + + + + -------------------------------------- + -- Command line argument processing -- + -------------------------------------- + + procedure Process + (Config : Configuration; + Handler : in out Handlers.Callback'Class; + Argument_Count : not null access function return Natural + := Ada.Command_Line.Argument_Count'Access; + Argument : not null access function (Number : Positive) return String + := Ada.Command_Line.Argument'Access); + -- Process system command line argument list, using the provided option + -- definitions and handler callbacks. + +private + + type Option (Long_Name_Length : Natural) is record + Id : Option_Id; + Has_Arg : Argument_Requirement; + Long_Name : String (1 .. Long_Name_Length); + Short_Name : Character; + end record; + + package Long_Option_Maps is + new Ada.Containers.Indefinite_Ordered_Maps (String, Option); + + package Short_Option_Maps is + new Ada.Containers.Indefinite_Ordered_Maps (Character, Option); + + type Configuration is tagged record + By_Long_Name : Long_Option_Maps.Map; + By_Short_Name : Short_Option_Maps.Map; + Posixly_Correct : Boolean := True; + Long_Only : Boolean := False; + end record; + +end Natools.Getopt_Long; ADDED src/natools-tests-text_io.adb Index: src/natools-tests-text_io.adb ================================================================== --- src/natools-tests-text_io.adb +++ src/natools-tests-text_io.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Text_IO; + +package body Natools.Tests.Text_IO is + + ------------------------ + -- Helper subprograms -- + ------------------------ + + function Indentation (Level : Natural) return String; + -- Return the indentation string for the given level. + + function Indentation (Report : Text_Reporter) return String; + -- Return the indentation string for the current level of Report. + + + function Indentation (Level : Natural) return String is + use Ada.Strings.Fixed; + begin + return Level * " "; + end Indentation; + + + function Indentation (Report : Text_Reporter) return String is + begin + return Indentation (Natural (Report.Results.Length)); + end Indentation; + + + ------------------------ + -- Public subprograms -- + ------------------------ + + procedure Section (Report : in out Text_Reporter; Name : String) is + begin + Ada.Text_IO.Put_Line (Indentation (Report) & "Section: " & Name); + Result_Lists.Append (Report.Results, (others => 0)); + end Section; + + + procedure End_Section (Report : in out Text_Reporter) is + Last_Item : Result_Lists.Cursor := Report.Results.Last; + begin + Result_Lists.Delete (Report.Results, Last_Item); + end End_Section; + + + procedure Item + (Report : in out Text_Reporter; + Name : in String; + Outcome : in Result) + is + use Ada.Strings.Fixed; + + procedure Process (Position : Result_Lists.Cursor); + procedure Update (R : in out Result_Summary); + + Indent : constant String := Indentation (Report); + Text_Size : constant Positive + := Indent'Length + Name'Length + Max_Result_String_Size + 1; + Line_Length : constant Natural + := Natural (Ada.Text_IO.Line_Length); + + procedure Process (Position : Result_Lists.Cursor) is + begin + Result_Lists.Update_Element (Report.Results, Position, Update'Access); + end Process; + + procedure Update (R : in out Result_Summary) is + begin + R (Outcome) := R (Outcome) + 1; + end Update; + begin + if Text_Size < Line_Length then + Ada.Text_IO.Put_Line (Indent & Name + & (Line_Length - Text_Size) * " " + & Result'Image (Outcome)); + else + Ada.Text_IO.Put_Line (Indent & Name); + Ada.Text_IO.Put_Line (Indent & " -> " & Result'Image (Outcome)); + end if; + Result_Lists.Iterate (Report.Results, Process'Access); + Report.Total (Outcome) := Report.Total (Outcome) + 1; + end Item; + + + procedure Info (Report : in out Text_Reporter; Text : String) is + pragma Unreferenced (Report); + begin + Ada.Text_IO.Put_Line (Text); + end Info; + + + function Current_Results (Report : Text_Reporter) return Result_Summary is + begin + return Result_Lists.Element (Report.Results.Last); + end Current_Results; + + function Total_Results (Report : Text_Reporter) return Result_Summary is + begin + return Report.Total; + end Total_Results; + + + procedure Print_Results (R : Result_Summary) is + use Ada.Strings.Fixed; + begin + for I in R'Range loop + declare + Image : constant String := Result'Image (I); + begin + Ada.Text_IO.Put_Line + (Image + & (Max_Result_String_Size + 1 - Image'Length) * " " + & Natural'Image (R (I))); + end; + end loop; + end Print_Results; +end Natools.Tests.Text_IO; ADDED src/natools-tests-text_io.ads Index: src/natools-tests-text_io.ads ================================================================== --- src/natools-tests-text_io.ads +++ src/natools-tests-text_io.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Tests.Text_IO is a simple implementation of Natools.Tests -- +-- interface. It immediately prints Item and Info to default output using -- +-- Ada.Text_IO facilities. Current and total result summaries are stored -- +-- in a stack using Doubly_Linked_Lists. -- +-- Sections are represented by a two-space indentation. -- +------------------------------------------------------------------------------ + +private with Ada.Containers.Doubly_Linked_Lists; + +package Natools.Tests.Text_IO is + + type Text_Reporter is new Reporter with private; + + procedure Section (Report : in out Text_Reporter; Name : String); + -- Start a new (sub)section. This prints section header and increments + -- indentation. + + procedure End_Section (Report : in out Text_Reporter); + -- End the current (sub)section. This does not output anything, but + -- decrements the current indentation. + + procedure Item + (Report : in out Text_Reporter; + Name : in String; + Outcome : in Result); + -- Output the Item with its outcome. If Line_Length is wide enough, + -- the outcome is right-aligned on the same line as the test name, + -- otherwise it is printed below with an additional indentation. + + procedure Info (Report : in out Text_Reporter; Text : String); + -- Output the Text directly. Association with previous Item is visual. + + function Current_Results (Report : Text_Reporter) return Result_Summary; + -- Return the number of each result type in the current subsection. + + function Total_Results (Report : Text_Reporter) return Result_Summary; + -- Return the total number of each result type. + + + procedure Print_Results (R : Result_Summary); + -- Pretty-print the result summary into the default output. + +private + + package Result_Lists is + new Ada.Containers.Doubly_Linked_Lists (Result_Summary); + + type Text_Reporter is new Reporter with record + Results : Result_Lists.List; + Total : Result_Summary := (others => 0); + end record; + +end Natools.Tests.Text_IO; ADDED src/natools-tests.adb Index: src/natools-tests.adb ================================================================== --- src/natools-tests.adb +++ src/natools-tests.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + + +package body Natools.Tests is + + function To_Result (Succeeded : Boolean) return Result is + begin + if Succeeded then + return Success; + else + return Fail; + end if; + end To_Result; + + + procedure Report_Exception + (Report : in out Reporter'Class; + Test_Name : String; + Ex : Ada.Exceptions.Exception_Occurrence; + Code : Result := Error) is + begin + Item (Report, Test_Name, Code); + Info (Report, + "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:"); + Info (Report, Ada.Exceptions.Exception_Message (Ex)); + end Report_Exception; + +end Natools.Tests; ADDED src/natools-tests.ads Index: src/natools-tests.ads ================================================================== --- src/natools-tests.ads +++ src/natools-tests.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Tests is an abstract interface for objects holding the results -- +-- of a series of tests. -- +-- -- +-- Each test can have one of the following results: -- +-- * Success, when everything goes well, -- +-- * Fail, when the test itself went fine the but the result is wrong, -- +-- * Error, when the test itself went wrong, which does not tell whether -- +-- the tested thing is fine or not, -- +-- * Skipped, when for any reason the test has not been performed -- +-- (e.g. missing dependency). -- +-- -- +-- Tests are gathered into sections, which can be nested. What a section -- +-- exactly means is left to the implementation of this interface. -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; + +package Natools.Tests is + pragma Preelaborate (Tests); + + type Reporter is interface; + type Result is (Success, Fail, Error, Skipped); + type Result_Summary is array (Result) of Natural; + + procedure Section (Report : in out Reporter; Name : String) is abstract; + procedure End_Section (Report : in out Reporter) is abstract; + -- These procedures change the internal state of Report to respectively + -- enter and leave a (sub)section. + + procedure Item + (Report : in out Reporter; + Name : in String; + Outcome : in Result) + is abstract; + -- Append a new test item (with its outcome) to the current section + -- of Report. + + procedure Info (Report : in out Reporter; Text : String) is abstract; + -- Append free informational text related to the previous Item appended. + + function Current_Results (Report : Reporter) return Result_Summary + is abstract; + -- Return the number of each result type in the current section. + + function Total_Results (Report : Reporter) return Result_Summary + is abstract; + -- Return the total number of each result type in the current section. + + function To_Result (Succeeded : Boolean) return Result; + -- Return Success or Fail depending on the Boolean input. + + Max_Result_String_Size : constant Positive := 7; + -- Maximum length of any string returned by Result'Image. + + + ------------------------ + -- Helper subprograms -- + ------------------------ + + procedure Report_Exception + (Report : in out Reporter'Class; + Test_Name : String; + Ex : Ada.Exceptions.Exception_Occurrence; + Code : Result := Error); + -- Append to Report a new Item, whose result is Code, along with + -- a description of the exception Ex as Info entries. + +end Natools.Tests; ADDED src/natools.ads Index: src/natools.ads ================================================================== --- src/natools.ads +++ src/natools.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools is a collection of miscellaneous small utilities gathered in one -- +-- shared library. -- +------------------------------------------------------------------------------ + + +package Natools is + pragma Pure (Natools); + +end Natools; DELETED test_all.adb Index: test_all.adb ================================================================== --- test_all.adb +++ test_all.adb @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- Copyright (c) 2011, Natacha Porté -- --- -- --- Permission to use, copy, modify, and distribute this software for any -- --- purpose with or without fee is hereby granted, provided that the above -- --- copyright notice and this permission notice appear in all copies. -- --- -- --- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- --- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- --- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- --- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- --- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- --- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- --- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------ --- Test_All is a binary gathering all tests from Natools components. -- ------------------------------------------------------------------------ - -with Ada.Command_Line; -with Ada.Text_IO; -with Natools.Chunked_Strings.Tests; -with Natools.Getopt_Long_Tests; -with Natools.Tests.Text_IO; - -procedure Test_All is - package Uneven_Chunked_Strings is new Natools.Chunked_Strings - (Default_Allocation_Unit => 7, - Default_Chunk_Size => 15); - package Uneven_Chunked_Strings_Tests is new Uneven_Chunked_Strings.Tests; - - package Even_Chunked_Strings is new Natools.Chunked_Strings - (Default_Allocation_Unit => 6, - Default_Chunk_Size => 18); - package Even_Chunked_Strings_Tests is new Even_Chunked_Strings.Tests; - - package Single_Chunked_Strings is new Natools.Chunked_Strings - (Default_Allocation_Unit => 10, - Default_Chunk_Size => 10); - package Single_Chunked_Strings_Tests is new Single_Chunked_Strings.Tests; - - Report : Natools.Tests.Text_IO.Text_Reporter; -begin - Ada.Text_IO.Set_Line_Length (80); - Report.Section ("All Tests"); - - Report.Section ("Chunked_String with uneven allocation unit"); - Uneven_Chunked_Strings_Tests.All_Tests (Report); - Report.End_Section; - - Report.Section ("Chunked_String with even allocation unit"); - Even_Chunked_Strings_Tests.All_Tests (Report); - Report.End_Section; - - Report.Section ("Chunked_String with single allocation unit"); - Single_Chunked_Strings_Tests.All_Tests (Report); - Report.End_Section; - - Report.Section ("Getopt_Long"); - Natools.Getopt_Long_Tests.All_Tests (Report); - Report.End_Section; - - Natools.Tests.Text_IO.Print_Results (Report.Total_Results); - - declare - Results : constant Natools.Tests.Result_Summary := Report.Total_Results; - begin - if Results (Natools.Tests.Fail) > 0 or - Results (Natools.Tests.Error) > 0 - then - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); - else - Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); - end if; - end; - Report.End_Section; -end Test_All; ADDED tests/natools-chunked_strings-tests-cxa4010.adb Index: tests/natools-chunked_strings-tests-cxa4010.adb ================================================================== --- tests/natools-chunked_strings-tests-cxa4010.adb +++ tests/natools-chunked_strings-tests-cxa4010.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Strings; use Ada.Strings; + +procedure Natools.Chunked_Strings.Tests.CXA4010 + (Report : in out Natools.Tests.Reporter'Class) is +begin + Natools.Tests.Section (Report, "Port of ACATS CXA4010"); + + declare + + Pamphlet_Paragraph_Count : constant := 2; + Lines : constant := 4; + Line_Length : constant := 40; + + type Document_Type is array (Positive range <>) of Chunked_String; + + type Camera_Ready_Copy_Type is + array (1 .. Lines) of String (1 .. Line_Length); + + procedure Enter_Text_Into_Document (Document : in out Document_Type); + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type); + procedure Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type); + + Pamphlet : Document_Type (1 .. Pamphlet_Paragraph_Count); + Camera_Ready_Copy : Camera_Ready_Copy_Type := + (others => (others => Ada.Strings.Space)); + TC_Finished_Product : constant Camera_Ready_Copy_Type := + (1 => "Ada is a programming language designed ", + 2 => "to support long-lived, reliable software", + 3 => " systems. ", + 4 => "Go with Ada! "); + + + procedure Enter_Text_Into_Document (Document : in out Document_Type) is + begin + Document (1) := To_Chunked_String ("Ada is a language"); + Document (1) := Insert (Document (1), + Index (Document (1), "language"), + To_String ("progra" + & Chunked_Strings."*" (2, 'm') + & "ing ")); + Document (1) := + Overwrite (Document (1), + Index (Document (1), + To_String (Tail (Document (1), 8, ' ')), + Ada.Strings.Backward), + "language designed to support long-lifed"); + Document (1) := + Overwrite (Document (1), + Index (Document (1), + To_String (Tail (Document (1), 5, ' ')), + Ada.Strings.Backward), + "lived, reliable software systems."); + Document (2) := 'G' + & To_Chunked_String ("o ") + & To_Chunked_String ("with") + & ' ' + & "Ada!"; + end Enter_Text_Into_Document; + + + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type) is + begin + Camera_Copy (1) := + Slice (Document (1), + 1, + Index (To_Chunked_String (Slice (Document (1), + 1, Line_Length)), + Ada.Strings.Maps.To_Set (' '), + Ada.Strings.Inside, + Ada.Strings.Backward)) + & ' '; + Camera_Copy (2) := + Slice (Document (1), + 40, + Index_Non_Blank (To_Chunked_String (Slice (Document (1), + 40, 79)), + Ada.Strings.Backward) + 39); + Camera_Copy (3) (1 .. 9) := + Slice (Document (1), 80, Length (Document (1))); + Camera_Copy (4) (1 .. Length (Document (2))) := + To_String (Head (Document (2), Length (Document (2)))); + end Create_Camera_Ready_Copy; + + + procedure Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) is + begin + for I in Draft'Range loop + declare + Name : constant String := "Slice" & Positive'Image (I); + begin + if Draft (I) = Master (I) then + Natools.Tests.Item (Report, Name, Natools.Tests.Success); + else + Natools.Tests.Item (Report, Name, Natools.Tests.Fail); + Natools.Tests.Info (Report, "Draft: """ & Draft (I) & '"'); + Natools.Tests.Info (Report, "Master: """ & Master (I) & '"'); + end if; + exception + when Error : others => + Natools.Tests.Report_Exception (Report, Name, Error); + end; + end loop; + end Valid_Proofread; + begin + Enter_Text_Into_Document (Pamphlet); + Create_Camera_Ready_Copy (Document => Pamphlet, + Camera_Copy => Camera_Ready_Copy); + Valid_Proofread (Draft => Camera_Ready_Copy, + Master => TC_Finished_Product); + exception + when Error : others => + Natools.Tests.Report_Exception (Report, "Preparation", Error); + end; + + Natools.Tests.End_Section (Report); + +end Natools.Chunked_Strings.Tests.CXA4010; ADDED tests/natools-chunked_strings-tests-cxa4010.ads Index: tests/natools-chunked_strings-tests-cxa4010.ads ================================================================== --- tests/natools-chunked_strings-tests-cxa4010.ads +++ tests/natools-chunked_strings-tests-cxa4010.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests.CXA4010 is the transcription to -- +-- Chunked_String of ACATS test CXA4010 for Unbounded_String. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic procedure Natools.Chunked_Strings.Tests.CXA4010 + (Report : in out Natools.Tests.Reporter'Class); +pragma Preelaborate (CXA4010); ADDED tests/natools-chunked_strings-tests-cxa4011.adb Index: tests/natools-chunked_strings-tests-cxa4011.adb ================================================================== --- tests/natools-chunked_strings-tests-cxa4011.adb +++ tests/natools-chunked_strings-tests-cxa4011.adb @@ -0,0 +1,409 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Strings; use Ada.Strings; + +procedure Natools.Chunked_Strings.Tests.CXA4011 + (Report : in out Natools.Tests.Reporter'Class) +is + package NT renames Natools.Tests; + + procedure Test (Test_Name : String; + C_1 : Character; + C_2 : Character; + Name_1 : String; + Name_2 : String); + + + procedure Test (Test_Name : String; + C_1 : Character; + C_2 : Character; + Name_1 : String; + Name_2 : String) is + begin + if C_1 = C_2 then + NT.Item (Report, Test_Name, NT.Success); + else + NT.Item (Report, Test_Name, NT.Fail); + NT.Info (Report, Name_1 & ": " & Character'Image (C_1)); + NT.Info (Report, Name_2 & ": " & Character'Image (C_2)); + end if; + end Test; +begin + NT.Section (Report, "Port of ACATS CXA4011"); + + declare + Cad_String : constant Chunked_String + := To_Chunked_String ("cad"); + Complete_String : constant Chunked_String + := To_Chunked_String ("Incomplete") + & Ada.Strings.Space + & To_Chunked_String ("String"); + Incomplete_String : Chunked_String + := To_Chunked_String ("ncomplete Strin"); + Incorrect_Spelling : Chunked_String + := To_Chunked_String ("Guob Dai"); + Magic_String : constant Chunked_String + := To_Chunked_String ("abracadabra"); + Incantation : Chunked_String := Magic_String; + + A_Small_G : constant Character := 'g'; + A_Small_D : constant Character := 'd'; + + ABCD_Set : constant Maps.Character_Set := Maps.To_Set ("abcd"); + B_Set : constant Maps.Character_Set := Maps.To_Set ("b"); + AB_Set : constant Maps.Character_Set + := Maps."OR" (Maps.To_Set ('a'), B_Set); + + Code_Map : constant Maps.Character_Mapping + := Maps.To_Mapping (From => "abcd", To => "wxyz"); + Reverse_Code_Map : constant Maps.Character_Mapping + := Maps.To_Mapping (From => "wxyz", To => "abcd"); + Non_Existent_Map : constant Maps.Character_Mapping + := Maps.To_Mapping (From => "jkl", To => "mno"); + + Token_Start : array (1 .. 3) of Positive; + Token_End : array (1 .. 3) of Natural := (0, 0, 0); + Matching_Letters : Natural := 0; + + Tests : array (1 .. 5) of Boolean; + begin + declare + Name : constant String := "Operator ""&"""; + Tests : array (1 .. 3) of Boolean; + begin + Incomplete_String := 'I' & Incomplete_String; + Incomplete_String := Incomplete_String & A_Small_G; + if not Is_Valid (Incomplete_String) + or not Is_Valid (Complete_String) then + NT.Item (Report, Name, NT.Error); + if not Is_Valid (Incomplete_String) then + NT.Info (Report, "Incomplete_String is invalid"); + end if; + if not Is_Valid (Complete_String) then + NT.Info (Report, "Complete_String is invalid"); + end if; + else + Tests (1) := Incomplete_String < Complete_String; + Tests (2) := Incomplete_String > Complete_String; + Tests (3) := Incomplete_String /= Complete_String; + if Tests (1) or Tests (2) or Tests (3) then + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Incomplete_String: """ + & To_String (Incomplete_String) & '"'); + NT.Info (Report, "Complete_String: """ + & To_String (Complete_String) & '"'); + if Tests (1) then + NT.Info (Report, "-> Incomplete_String < Complete_String"); + end if; + if Tests (2) then + NT.Info (Report, "-> Incomplete_String < Complete_String"); + end if; + if Tests (3) then + NT.Info (Report, "-> Incomplete_String /= Complete_String"); + end if; + else + NT.Item (Report, Name, NT.Success); + end if; + end if; + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + NT.Section (Report, "Function Element"); + + declare + Name : constant String := "Element of complete vs constant"; + begin + Test (Name, + Element (Incomplete_String, Length (Incomplete_String)), + A_Small_G, + "Element (""" & To_String (Incomplete_String) + & ',' & Natural'Image (Length (Incomplete_String)) & ')', + "A_Small_G"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Element of complete vs Element of Tail"; + begin + Test (Name, + Element (Incomplete_String, 2), + Element (Tail (Incomplete_String, 2), 1), + "Element (""" & To_String (Incomplete_String) & ", 2)", + "Element (""" & To_String (Tail (Incomplete_String, 2)) + & ", 1)"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Element of Head vs Element of constant"; + begin + Test (Name, + Element (Head (Incomplete_String, 4), 2), + Element (To_Chunked_String ("wnqz"), 2), + "Element (""" & To_String (Head (Incomplete_String, 4)) + & ", 2)", + "Element (""wnqz"", 2)"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + declare + Name : constant String := "Procedure Replace_Element"; + begin + Replace_Element (Incorrect_Spelling, 2, 'o'); + Replace_Element (Incorrect_Spelling, + Index (Incorrect_Spelling, B_Set), + A_Small_D); + Replace_Element (Source => Incorrect_Spelling, + Index => Length (Incorrect_Spelling), + By => 'y'); + Test (Report, Name, Incorrect_Spelling, "Good Day"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + -- Function Count + Matching_Letters := Count (Source => Magic_String, + Set => ABCD_Set); + NT.Item (Report, "Function Count with Set parameter", + NT.To_Result (Matching_Letters = 9)); + if Matching_Letters /= 9 then + NT.Info + (Report, + "Count (""" & To_String (Magic_String) & """, ABCD_Set) " + & Natural'Image (Matching_Letters) + & " (should be 9)"); + Dump (Report, Magic_String); + end if; + Tests (1) := Count (Magic_String, "ab") + = Count (Magic_String, "ac") + Count (Magic_String, "ad"); + Tests (2) := Count (Magic_String, "ab") = 2; + NT.Item (Report, "Function Count with String parameter", + NT.To_Result (Tests (1) and Tests (2))); + if not Tests (1) or not Tests (2) then + NT.Info + (Report, + "Count (""" & To_String (Magic_String) & """, ""ab"") " + & Natural'Image (Count (Magic_String, "ab")) + & " (should be 2)"); + NT.Info + (Report, + "Count (""" & To_String (Magic_String) & """, ""ac"") " + & Natural'Image (Count (Magic_String, "ac"))); + NT.Info + (Report, + "Count (""" & To_String (Magic_String) & """, ""ad"") " + & Natural'Image (Count (Magic_String, "ad"))); + end if; + + -- Find_Token + Find_Token (Magic_String, + AB_Set, + Ada.Strings.Inside, + Token_Start (1), + Token_End (1)); + Tests (1) := Natural (Token_Start (1)) = To_String (Magic_String)'First + and Token_End (1) = Index (Magic_String, B_Set); + Find_Token (Source => Magic_String, + Set => ABCD_Set, + Test => Ada.Strings.Outside, + First => Token_Start (2), + Last => Token_End (2)); + Tests (2) := Natural (Token_Start (2)) = 3 and Token_End (2) = 3; + Find_Token (Magic_String, + Maps.To_Set (A_Small_G), + Ada.Strings.Inside, + First => Token_Start (3), + Last => Token_End (3)); + Tests (3) := Token_Start (3) = To_String (Magic_String)'First + and Token_End (3) = 0; + NT.Item (Report, "Procedure Find_Token", + NT.To_Result (Tests (1) and Tests (2) and Tests (3))); + if not Tests (1) then + NT.Info (Report, + "Start: " + & Positive'Image (Token_Start (1)) & " /= " + & Positive'Image (To_String (Magic_String)'First) + & " (should be both 1)"); + NT.Info (Report, + "End: " + & Natural'Image (Token_End (1)) & " /= " + & Natural'Image (Index (Magic_String, B_Set)) + & " (should be both 2)"); + end if; + if not Tests (2) then + NT.Info + (Report, + "Start: " & Positive'Image (Token_Start (2)) & " (should be 3)"); + NT.Info + (Report, + "End: " & Natural'Image (Token_End (2)) & " (should be 3)"); + end if; + if not Tests (3) then + NT.Info + (Report, + "Start: " + & Positive'Image (Token_Start (3)) & " /= " + & Positive'Image (To_String (Magic_String)'First) + & " (should be 1)"); + NT.Info + (Report, + "End: " + & Natural'Image (Token_End (3)) & " (should be 0)"); + end if; + + -- Translate + Incantation := Translate (Magic_String, Code_Map); + Tests (1) := Incantation = To_Chunked_String ("wxrwywzwxrw"); + NT.Item (Report, "Function Translate", + NT.To_Result (Tests (1))); + if not Tests (1) then + NT.Info (Report, + '"' & To_String (Incantation) + & """ /= ""wxrwywzwxrw"""); + end if; + Translate (Incantation, Reverse_Code_Map); + Tests (1) := Incantation = Translate (Magic_String, Non_Existent_Map); + NT.Item + (Report, "Procedure Translate", NT.To_Result (Tests (1))); + if not Tests (1) then + NT.Info (Report, + '"' & To_String (Incantation) & """ /= """ + & To_String (Translate (Magic_String, + Non_Existent_Map)) + & """ (should be """ + & To_String (Magic_String) & """)"); + end if; + + -- Trim + declare + XYZ_Set : constant Maps.Character_Set := Maps.To_Set ("xyz"); + PQR_Set : constant Maps.Character_Set := Maps.To_Set ("pqr"); + Pad : constant Chunked_String := To_Chunked_String ("Pad"); + The_New_Ada : constant Chunked_String := To_Chunked_String ("Ada9X"); + Space_Array : constant array (1 .. 4) of Chunked_String + := (To_Chunked_String (" Pad "), + To_Chunked_String ("Pad "), + To_Chunked_String (" Pad"), + Pad); + String_Array : constant array (1 .. 5) of Chunked_String + := (To_Chunked_String ("xyzxAda9Xpqr"), + To_Chunked_String ("Ada9Xqqrp"), + To_Chunked_String ("zxyxAda9Xqpqr"), + To_Chunked_String ("xxxyAda9X"), + The_New_Ada); + begin + for I in 1 .. 4 loop + Tests (I) := Trim (Space_Array (I), Ada.Strings.Both) = Pad; + end loop; + NT.Item + (Report, "Trim spaces", + NT.To_Result (Tests (1) and Tests (2) + and Tests (3) and Tests (4))); + for I in 1 .. 4 loop + if not Tests (I) then + NT.Info + (Report, + "Part" & Positive'Image (I) & ": Trim (""" + & To_String (Space_Array (I)) & """, Both) -> """ + & To_String (Trim (Space_Array (I), Ada.Strings.Both)) + & """ (shoud be """ & To_String (Pad) & '"'); + end if; + end loop; + + for I in 1 .. 5 loop + Tests (I) := Trim (String_Array (I), + Left => XYZ_Set, + Right => PQR_Set) + = The_New_Ada; + end loop; + NT.Item + (Report, "Trim sets of characters", + NT.To_Result (Tests (1) and Tests (2) and Tests (3) + and Tests (4) and Tests (5))); + for I in 1 .. 5 loop + if not Tests (I) then + NT.Info + (Report, + "Part" & Positive'Image (I) & ": Trim (""" + & To_String (String_Array (I)) + & """, XYZ_Set, PQR_Set) -> """ + & To_String (Trim (String_Array (I), XYZ_Set, PQR_Set)) + & """ (shoud be """ & To_String (The_New_Ada) & '"'); + end if; + end loop; + end; + + -- Delete + Tests (1) := Delete (Source => Delete (Magic_String, + 8, Length (Magic_String)), + From => To_String (Magic_String)'First, + Through => 4) + = Cad_String; + NT.Item (Report, "Function Delete", + NT.To_Result (Tests (1))); + if not Tests (1) then + NT.Info + (Report, + '"' & To_String (Delete (Delete (Magic_String, + 8, Length (Magic_String)), + To_String (Magic_String)'First, 4)) + & """ /= """ & To_String (Cad_String) & '"'); + end if; + + -- Constructors "*" + declare + SOS : Chunked_String; + Dot : constant Chunked_String := To_Chunked_String ("Dot_"); + Dash : constant String := "Dash_"; + Distress : constant Chunked_String + := To_Chunked_String ("Dot_Dot_Dot_") + & To_Chunked_String ("Dash_Dash_Dash_") + & To_Chunked_String ("Dot_Dot_Dot"); + Repeat : constant Natural := 3; + Separator : constant Character := '_'; + Separator_Set : constant Maps.Character_Set + := Maps.To_Set (Separator); + begin + SOS := Repeat * Dot; + SOS := SOS & Repeat * Dash & Repeat * Dot; + if Trim (SOS, Maps.Null_Set, Separator_Set) /= Distress then + NT.Item (Report, "Function ""*""", NT.Fail); + NT.Info + (Report, + '"' & To_String (Trim (SOS, Maps.Null_Set, Separator_Set)) + & """ /= """ & To_String (Distress) & '"'); + else + NT.Item (Report, "Function ""*""", + NT.Success); + end if; + end; + exception + when Error : others => + NT.Report_Exception (Report, "Preparation", Error); + end; + + NT.End_Section (Report); + +end Natools.Chunked_Strings.Tests.CXA4011; ADDED tests/natools-chunked_strings-tests-cxa4011.ads Index: tests/natools-chunked_strings-tests-cxa4011.ads ================================================================== --- tests/natools-chunked_strings-tests-cxa4011.ads +++ tests/natools-chunked_strings-tests-cxa4011.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests.CXA4011 is the transcription to -- +-- Chunked_String of ACATS test CXA4011 for Unbounded_String. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic procedure Natools.Chunked_Strings.Tests.CXA4011 + (Report : in out Natools.Tests.Reporter'Class); +pragma Preelaborate (CXA4011); ADDED tests/natools-chunked_strings-tests-cxa4030.adb Index: tests/natools-chunked_strings-tests-cxa4030.adb ================================================================== --- tests/natools-chunked_strings-tests-cxa4030.adb +++ tests/natools-chunked_strings-tests-cxa4030.adb @@ -0,0 +1,549 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Characters.Latin_1; +with Ada.Exceptions; +with Ada.Strings; use Ada.Strings; + +procedure Natools.Chunked_Strings.Tests.CXA4030 + (Report : in out Natools.Tests.Reporter'Class) +is + package NT renames Natools.Tests; +begin + NT.Section (Report, "Port of ACATS CXA4030"); + + declare + package L1 renames Ada.Characters.Latin_1; + + New_Character_String : Chunked_String + := To_Chunked_String (L1.LC_A_Grave & L1.LC_A_Ring + & L1.LC_AE_Diphthong & L1.LC_C_Cedilla + & L1.LC_E_Acute & L1.LC_I_Circumflex + & L1.LC_Icelandic_Eth & L1.LC_N_Tilde + & L1.LC_O_Oblique_Stroke & L1.LC_Icelandic_Thorn); + + TC_New_Character_String : constant Chunked_String + := To_Chunked_String (L1.UC_A_Grave & L1.UC_A_Ring + & L1.UC_AE_Diphthong & L1.UC_C_Cedilla + & L1.UC_E_Acute & L1.UC_I_Circumflex + & L1.UC_Icelandic_Eth & L1.UC_N_Tilde + & L1.UC_O_Oblique_Stroke & L1.UC_Icelandic_Thorn); + Map_To_Lower_Case_Ptr : constant Maps.Character_Mapping_Function + := Ada.Characters.Handling.To_Lower'Access; + Map_To_Upper_Case_Ptr : constant Maps.Character_Mapping_Function + := Ada.Characters.Handling.To_Upper'Access; + begin + NT.Section (Report, "Function Index, Forward direction"); + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Test (Report, Name, + Index (Source => To_Chunked_String + ("The library package Strings.Unbounded"), + Pattern => "unb", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr), + 29); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower"; + begin + Test (Report, Name, + Index (To_Chunked_String + ("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"), + "ain", + Mapping => Map_To_Lower_Case_Ptr), + 6); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to lower"; + begin + Test (Report, Name, + Index (To_Chunked_String ("maximum number"), + "um", + Ada.Strings.Forward, + Ada.Characters.Handling.To_Lower'Access), + 6); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to upper"; + begin + Test (Report, Name, + Index (To_Chunked_String ("CoMpLeTeLy MiXeD CaSe StRiNg"), + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr), + 12); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower (no match)"; + begin + Test (Report, Name, + Index (To_Chunked_String + ("STRING WITH NO MATCHING PATTERNS"), + "WITH", + Mapping => Map_To_Lower_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to upper"; + begin + Test (Report, Name, + Index (To_Chunked_String ("THIS STRING IS IN UPPER CASE"), + "IS", + Ada.Strings.Forward, + Ada.Characters.Handling.To_Upper'Access), + 3); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Null string"; + begin + Test (Report, Name, + Index (Null_Chunked_String, + "is", + Mapping => Map_To_Lower_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower"; + begin + Test (Report, Name, + Index (To_Chunked_String ("AAABBBaaabbb"), + "aabb", + Mapping => Ada.Characters.Handling.To_Lower'Access), + 2); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Function Index, Backward direction"); + + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Test (Report, Name, + Index (To_Chunked_String ("Case of a Mixed Case String"), + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr), + 17); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to upper"; + begin + Test (Report, Name, + Index (To_Chunked_String ("Case of a Mixed Case String"), + "CASE", + Ada.Strings.Backward, + Mapping => Map_To_Upper_Case_Ptr), + 17); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower"; + begin + Test (Report, Name, + Index (To_Chunked_String ("rain, Rain, and more RAIN"), + "rain", + Ada.Strings.Backward, + Ada.Characters.Handling.To_Lower'Access), + 22); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to upper"; + begin + Test (Report, Name, + Index (To_Chunked_String ("RIGHT place, right time"), + "RIGHT", + Going => Ada.Strings.Backward, + Mapping => Ada.Characters.Handling.To_Upper'Access), + 14); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower (no match)"; + begin + Test (Report, Name, + Index (To_Chunked_String ("WOULD MATCH BUT FOR THE CASE"), + "WOULD MATCH BUT FOR THE CASE", + Going => Ada.Strings.Backward, + Mapping => Map_To_Lower_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + declare + Null_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural + := Index (To_Chunked_String ("A Valid Chunked String"), + Null_String, + Going => Ada.Strings.Forward, + Mapping => Ada.Characters.Handling.To_Lower'Access); + NT.Item (Report, "Pattern_Error raised in Index", NT.Fail); + NT.Info (Report, "No exception has been raised."); + NT.Info (Report, "Return value: " & Natural'Image (TC_Natural)); + exception + when Pattern_Error => + NT.Item (Report, "Pattern_Error raised in Index", NT.Success); + when Error : others => + NT.Item (Report, "Pattern_Error raised in Index", NT.Fail); + NT.Info (Report, "Wrong exception " + & Ada.Exceptions.Exception_Name (Error) + & "has been raised."); + end; + + + NT.Section (Report, "Function Count with mapping function"); + + declare + Name : constant String := "Upper case mapped to lower"; + begin + Test (Report, Name, + Count (Source => To_Chunked_String ("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr), + 2); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower (no match)"; + begin + Test (Report, Name, + Count (To_Chunked_String ("ABABABA"), + "ABA", + Mapping => Map_To_Lower_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Test (Report, Name, + Count (To_Chunked_String ("This IS a MISmatched issue"), + "is", + Ada.Characters.Handling.To_Lower'Access), + 4); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to upper"; + begin + Test (Report, Name, + Count (To_Chunked_String ("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr), + 2); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to upper (no match)"; + begin + Test (Report, Name, + Count (To_Chunked_String ("This IS a MISmatched issue"), + "is", + Mapping => Map_To_Upper_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Test (Report, Name, + Count (To_Chunked_String + ("She sells sea shells by the sea shore"), + "s", + Ada.Characters.Handling.To_Lower'Access), + 8); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty string"; + begin + Test (Report, Name, + Count (Null_Chunked_String, + "match", + Map_To_Upper_Case_Ptr), + 0); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + declare + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count (To_Chunked_String ("A Valid String"), + Null_Pattern_String, + Map_To_Lower_Case_Ptr); + NT.Item (Report, "Pattern_Error raised in Count", NT.Fail); + NT.Info (Report, "No exception has been raised."); + NT.Info (Report, "Return value: " & Natural'Image (TC_Natural)); + exception + when Pattern_Error => + NT.Item (Report, "Pattern_Error raised in Count", NT.Success); + when Error : others => + NT.Item (Report, "Pattern_Error raised in Count", NT.Fail); + NT.Info (Report, "Wrong exception " + & Ada.Exceptions.Exception_Name (Error) + & "has been raised."); + end; + + + NT.Section (Report, "Function Translate"); + + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Test (Report, Name, + Translate (Source => To_Chunked_String + ("A Sample Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr), + "a sample mixed case string"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to lower"; + begin + Test (Report, Name, + Translate (To_Chunked_String ("ALL LOWER CASE"), + Ada.Characters.Handling.To_Lower'Access), + "all lower case"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to lower"; + begin + Test (Report, Name, + Translate (To_Chunked_String ("end with lower case"), + Map_To_Lower_Case_Ptr), + "end with lower case"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty string"; + begin + Test (Report, Name, + Translate (Null_Chunked_String, + Ada.Characters.Handling.To_Lower'Access), + Null_Chunked_String); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to upper"; + begin + Test (Report, Name, + Translate (To_Chunked_String ("start with lower case"), + Map_To_Upper_Case_Ptr), + "START WITH LOWER CASE"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Upper case mapped to upper"; + begin + Test (Report, Name, + Translate (To_Chunked_String ("ALL UPPER CASE STRING"), + Ada.Characters.Handling.To_Upper'Access), + "ALL UPPER CASE STRING"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to upper"; + begin + Test (Report, Name, + Translate (To_Chunked_String + ("LoTs Of MiXeD CaSe ChArAcTeRs"), + Map_To_Upper_Case_Ptr), + "LOTS OF MIXED CASE CHARACTERS"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Diacritics"; + begin + Test (Report, Name, + Translate (New_Character_String, + Ada.Characters.Handling.To_Upper'Access), + TC_New_Character_String); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Procedure Translate"); + + declare + use Ada.Characters.Handling; + + Str_1 : Chunked_String + := To_Chunked_String ("AN ALL UPPER CASE STRING"); + Str_2 : Chunked_String + := To_Chunked_String ("A Mixed Case String"); + Str_3 : Chunked_String + := To_Chunked_String ("a string with lower case letters"); + TC_Str_1 : constant Chunked_String := Str_1; + TC_Str_3 : constant Chunked_String := Str_3; + begin + declare + Name : constant String := "Upper case mapped to lower"; + begin + Translate (Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); + Test (Report, Name, Str_1, + To_Chunked_String ("an all upper case string")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped back to upper"; + begin + Translate (Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); + Test (Report, Name, Str_1, TC_Str_1); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Mixed case mapped to lower"; + begin + Translate (Str_2, Mapping => Map_To_Lower_Case_Ptr); + Test (Report, Name, Str_2, + To_Chunked_String ("a mixed case string")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to upper"; + begin + Translate (Str_2, Mapping => To_Upper'Access); + Test (Report, Name, Str_2, + To_Chunked_String ("A MIXED CASE STRING")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to lower"; + begin + Translate (Str_3, To_Lower'Access); + Test (Report, Name, Str_3, TC_Str_3); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Lower case mapped to upper"; + begin + Translate (Str_3, To_Upper'Access); + Test (Report, Name, Str_3, + To_Chunked_String ("A STRING WITH LOWER CASE LETTERS")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Diacritics"; + begin + Translate (New_Character_String, Map_To_Upper_Case_Ptr); + Test (Report, Name, New_Character_String, TC_New_Character_String); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + end; + + NT.End_Section (Report); + exception + when Error : others => + NT.Item (Report, "Preparation", NT.Error); + NT.Info (Report, "Exception: " + & Ada.Exceptions.Exception_Name (Error)); + NT.Info (Report, Ada.Exceptions.Exception_Message (Error)); + end; + + NT.End_Section (Report); + +end Natools.Chunked_Strings.Tests.CXA4030; ADDED tests/natools-chunked_strings-tests-cxa4030.ads Index: tests/natools-chunked_strings-tests-cxa4030.ads ================================================================== --- tests/natools-chunked_strings-tests-cxa4030.ads +++ tests/natools-chunked_strings-tests-cxa4030.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests.CXA4030 is the transcription to -- +-- Chunked_String of ACATS test CXA4030 for Unbounded_String. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic procedure Natools.Chunked_Strings.Tests.CXA4030 + (Report : in out Natools.Tests.Reporter'Class); +pragma Preelaborate (CXA4030); ADDED tests/natools-chunked_strings-tests-cxa4031.adb Index: tests/natools-chunked_strings-tests-cxa4031.adb ================================================================== --- tests/natools-chunked_strings-tests-cxa4031.adb +++ tests/natools-chunked_strings-tests-cxa4031.adb @@ -0,0 +1,440 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; + +procedure Natools.Chunked_Strings.Tests.CXA4031 + (Report : in out Natools.Tests.Reporter'Class) +is + package NT renames Natools.Tests; +begin + NT.Section (Report, "Port of ACATS CXA4031"); + + declare + subtype LC_Characters is Character range 'a' .. 'z'; + + Null_String : constant String := ""; + TC_String : constant String := "A Standard String"; + + TC_Chunked_String, + TC_New_Chunked_String : Chunked_String := Null_Chunked_String; + begin + NT.Section (Report, "Function To_Chunked_String with Length parameter"); + + declare + Name : constant String := "Length = 10"; + Result : Natural; + begin + Result := Length (To_Chunked_String (Length => 10)); + if Result = 10 then + NT.Item (Report, Name, NT.Success); + else + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Found length" & Natural'Image (Result)); + end if; + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Singleton"; + Result : Natural; + begin + Result := Length (To_Chunked_String (1)); + if Result = 1 then + NT.Item (Report, Name, NT.Success); + else + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Found length" & Natural'Image (Result)); + end if; + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty string"; + Result : Natural; + begin + Result := Length (To_Chunked_String (0)); + if Result = 0 then + NT.Item (Report, Name, NT.Success); + else + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Found length" & Natural'Image (Result)); + end if; + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Concatenation of the above"; + Result : Natural; + begin + Result := Length (To_Chunked_String (Length => 10) + & To_Chunked_String (1) + & To_Chunked_String (0)); + if Result = 10 + 1 + 0 then + NT.Item (Report, Name, NT.Success); + else + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Found length" & Natural'Image (Result)); + end if; + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Append (Chunked, Chunked)"); + + declare + Name : constant String := "Non-empty and non-empty"; + begin + TC_Chunked_String := To_Chunked_String ("Sample string of length L"); + TC_New_Chunked_String := To_Chunked_String (" and then some"); + Append (TC_Chunked_String, TC_New_Chunked_String); + Test (Report, Name, TC_Chunked_String, + "Sample string of length L and then some"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Non-empty and empty"; + begin + TC_Chunked_String := To_Chunked_String ("Sample string of length L"); + TC_New_Chunked_String := Null_Chunked_String; + Test (Report, Name, TC_Chunked_String, "Sample string of length L"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty and non-empty"; + begin + TC_Chunked_String := Null_Chunked_String; + Append (TC_Chunked_String, + To_Chunked_String ("New Chunked String")); + Test (Report, Name, TC_Chunked_String, "New Chunked String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Procedure Append (Chunked, String)"); + + declare + Name : constant String := "Non-empty and non-empty"; + begin + TC_Chunked_String := To_Chunked_String ("A Chunked String and "); + Append (Source => TC_Chunked_String, New_Item => TC_String); + Test (Report, Name, TC_Chunked_String, + "A Chunked String and A Standard String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Non-empty and empty"; + begin + TC_Chunked_String := To_Chunked_String ("A Chunked String"); + Append (TC_Chunked_String, New_Item => Null_String); + Test (Report, Name, TC_Chunked_String, "A Chunked String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty and non-empty"; + begin + TC_Chunked_String := Null_Chunked_String; + Append (TC_Chunked_String, TC_String); + Test (Report, Name, TC_Chunked_String, "A Standard String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Procedure Append (Chunked, Character)"); + + declare + Name : constant String := "Non-empty initial string"; + begin + TC_Chunked_String := To_Chunked_String ("Lower Case = "); + for I in LC_Characters'Range loop + Append (Source => TC_Chunked_String, + New_Item => I); + end loop; + Test (Report, Name, TC_Chunked_String, + "Lower Case = abcdefghijklmnopqrstuvwxyz"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty initial string"; + begin + TC_Chunked_String := Null_Chunked_String; + Append (TC_Chunked_String, New_Item => 'a'); + Test (Report, Name, TC_Chunked_String, "a"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Function ""="""); + TC_Chunked_String := To_Chunked_String (TC_String); + + declare + Name : constant String := "Chunked_String and String"; + begin + NT.Item (Report, Name, NT.To_Result (TC_Chunked_String = TC_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "String and Chunked_String"; + begin + NT.Item (Report, Name, + NT.To_Result ("A Standard String" = TC_Chunked_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty chunked string and empty string"; + begin + NT.Item (Report, Name, NT.To_Result (Null_Chunked_String = "")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "With inline conversion"; + begin + NT.Item (Report, Name, + NT.To_Result ("Test String" = To_Chunked_String ("Test String"))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Function ""<"""); + + declare + Name : constant String := "Differing by a trailing space"; + begin + NT.Item (Report, Name, + NT.To_Result ("Extra Space" < To_Chunked_String ("Extra Space "))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by the last letter"; + begin + NT.Item (Report, Name, + NT.To_Result (To_Chunked_String ("tess") < "test")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by the first letter"; + begin + NT.Item (Report, Name, + NT.To_Result (To_Chunked_String ("best") < "test")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty strings"; + begin + NT.Item (Report, Name, + NT.To_Result (not (Null_Chunked_String < Null_String))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Equal with leading blank"; + begin + NT.Item (Report, Name, + NT.To_Result (not (" leading blank" + < To_Chunked_String (" leading blank")))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Equal with ending blank"; + begin + NT.Item (Report, Name, + NT.To_Result (not ("ending blank " + < To_Chunked_String ("ending blank ")))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Function ""<="""); + TC_Chunked_String := To_Chunked_String ("Sample string"); + + declare + Name : constant String := "Prefix"; + begin + NT.Item (Report, Name, + NT.To_Result (not (TC_Chunked_String <= "Sample strin"))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by case"; + begin + NT.Item (Report, Name, + NT.To_Result (not ("sample string" <= TC_Chunked_String))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty strings"; + begin + NT.Item (Report, Name, NT.To_Result (Null_Chunked_String <= "")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Equal strings"; + begin + NT.Item (Report, Name, + NT.To_Result ("Sample string" <= TC_Chunked_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Function "">"""); + TC_Chunked_String := To_Chunked_String ("A MUCH LONGER STRING"); + + declare + Name : constant String := "Differing by case"; + begin + NT.Item (Report, Name, + NT.To_Result ("A much longer string" > TC_Chunked_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Prefix"; + begin + NT.Item (Report, Name, + NT.To_Result (To_Chunked_String (TC_String) > "A Standard Strin")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by case"; + begin + NT.Item (Report, Name, + NT.To_Result ("abcdefgh" > To_Chunked_String ("ABCDEFGH"))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty strings"; + begin + NT.Item (Report, Name, + NT.To_Result (not (Null_Chunked_String > Null_String))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + + NT.Section (Report, "Function "">="""); + TC_Chunked_String := To_Chunked_String (TC_String); + + declare + Name : constant String := "Equal strings"; + begin + NT.Item (Report, Name, NT.To_Result (TC_Chunked_String >= TC_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Empty strings"; + begin + NT.Item (Report, Name, + NT.To_Result (Null_String >= Null_Chunked_String)); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by the last letter"; + begin + NT.Item (Report, Name, + NT.To_Result ("test" >= To_Chunked_String ("tess"))); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + declare + Name : constant String := "Differing by case"; + begin + NT.Item (Report, Name, + NT.To_Result (To_Chunked_String ("Programming") >= "PROGRAMMING")); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + exception + when Error : others => + NT.Item (Report, "Preparation", NT.Error); + NT.Info (Report, "Exception: " + & Ada.Exceptions.Exception_Name (Error)); + NT.Info (Report, Ada.Exceptions.Exception_Message (Error)); + end; + + NT.End_Section (Report); + +end Natools.Chunked_Strings.Tests.CXA4031; ADDED tests/natools-chunked_strings-tests-cxa4031.ads Index: tests/natools-chunked_strings-tests-cxa4031.ads ================================================================== --- tests/natools-chunked_strings-tests-cxa4031.ads +++ tests/natools-chunked_strings-tests-cxa4031.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests.CXA4031 is the transcription to -- +-- Chunked_String of ACATS test CXA4031 for Unbounded_String. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic procedure Natools.Chunked_Strings.Tests.CXA4031 + (Report : in out Natools.Tests.Reporter'Class); +pragma Preelaborate (CXA4031); ADDED tests/natools-chunked_strings-tests-cxa4032.adb Index: tests/natools-chunked_strings-tests-cxa4032.adb ================================================================== --- tests/natools-chunked_strings-tests-cxa4032.adb +++ tests/natools-chunked_strings-tests-cxa4032.adb @@ -0,0 +1,536 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Strings.Maps.Constants; + +procedure Natools.Chunked_Strings.Tests.CXA4032 + (Report : in out Natools.Tests.Reporter'Class) +is + package NT renames Natools.Tests; +begin + NT.Section (Report, "Port of ACATS CXA4032"); + + declare + TC_Null_String : constant String := ""; + TC_String_5 : constant String (1 .. 5) := "ABCDE"; + TC_Chunked_String : Chunked_String := To_Chunked_String ("Test String"); + begin + NT.Section (Report, "Procedure Replace_Slice"); + declare + Name : constant String + := "Index_Error raised when Low > Source'Last+1"; + begin + Replace_Slice (Source => TC_Chunked_String, + Low => Length (TC_Chunked_String) + 2, + High => Length (TC_Chunked_String), + By => TC_String_5); + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "No exception has been raised."); + NT.Info (Report, + "Final value: """ & To_String (TC_Chunked_String) & '"'); + exception + when Ada.Strings.Index_Error => + NT.Item (Report, Name, NT.Success); + when Error : others => + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Wrong exception " + & Ada.Exceptions.Exception_Name (Error) + & " raised instead"); + end; + + + declare + Name : constant String := "1-character slice replacement"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Replace_Slice (TC_Chunked_String, 5, 5, TC_String_5); + Test (Report, Name, TC_Chunked_String, "TestABCDEString"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Prefix replacement"; + begin + Replace_Slice (TC_Chunked_String, 1, 4, TC_String_5); + Test (Report, Name, TC_Chunked_String, "ABCDEABCDEString"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Suffix replacement by empty"; + begin + Replace_Slice (TC_Chunked_String, + 11, + Length (TC_Chunked_String), + TC_Null_String); + Test (Report, Name, TC_Chunked_String, "ABCDEABCDE"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Slice insertion in the middle"; + begin + Replace_Slice (TC_Chunked_String, Low => 4, High => 1, By => "xxx"); + Test (Report, Name, TC_Chunked_String, "ABCxxxDEABCDE"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Slice insertion at the beginning"; + begin + Replace_Slice (TC_Chunked_String, Low => 1, High => 0, By => "yyy"); + Test (Report, Name, TC_Chunked_String, "yyyABCxxxDEABCDE"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Slice insertion at the end"; + begin + Replace_Slice (TC_Chunked_String, + Length (TC_Chunked_String) + 1, + Length (TC_Chunked_String), + By => "zzz"); + Test (Report, Name, TC_Chunked_String, "yyyABCxxxDEABCDEzzz"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Insert"); + TC_Chunked_String := To_Chunked_String ("Test String"); + + declare + Name : constant String := "Index_Error raised on incorrect Before"; + begin + Insert (Source => TC_Chunked_String, + Before => Length (TC_Chunked_String) + 2, + New_Item => TC_String_5); + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "No exception has been raised."); + NT.Info (Report, + "Final value: """ & To_String (TC_Chunked_String) & '"'); + exception + when Ada.Strings.Index_Error => + NT.Item (Report, Name, NT.Success); + when Error : others => + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Wrong exception " + & Ada.Exceptions.Exception_Name (Error) + & " raised instead"); + end; + + + declare + Name : constant String := "Prefix insertion"; + begin + Insert (TC_Chunked_String, 1, "**"); + Test (Report, Name, TC_Chunked_String, "**Test String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Suffix insertion"; + begin + Insert (TC_Chunked_String, Length (TC_Chunked_String) + 1, "**"); + Test (Report, Name, TC_Chunked_String, "**Test String**"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Insertion in the middle"; + begin + Insert (TC_Chunked_String, 8, "---"); + Test (Report, Name, TC_Chunked_String, "**Test ---String**"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty insertion"; + begin + Insert (TC_Chunked_String, 3, TC_Null_String); + Test (Report, Name, TC_Chunked_String, "**Test ---String**"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Overwrite"); + + declare + Name : constant String := "Index_Error raised on incorrect Position"; + begin + Overwrite (Source => TC_Chunked_String, + Position => Length (TC_Chunked_String) + 2, + New_Item => TC_String_5); + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "No exception has been raised."); + NT.Info (Report, + "Final value: """ & To_String (TC_Chunked_String) & '"'); + exception + when Ada.Strings.Index_Error => + NT.Item (Report, Name, NT.Success); + when Error : others => + NT.Item (Report, Name, NT.Fail); + NT.Info (Report, "Wrong exception " + & Ada.Exceptions.Exception_Name (Error) + & " raised instead"); + end; + + + declare + Name : constant String := "Normal overwrite"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Overwrite (Source => TC_Chunked_String, + Position => 1, + New_Item => "XXXX"); + Test (Report, Name, TC_Chunked_String, "XXXX String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Overwrite after the end"; + begin + Overwrite (TC_Chunked_String, Length (TC_Chunked_String) + 1, "**"); + Test (Report, Name, TC_Chunked_String, "XXXX String**"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty overwrite"; + begin + Overwrite (TC_Chunked_String, 3, TC_Null_String); + Test (Report, Name, TC_Chunked_String, "XXXX String**"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Complete overwrite"; + begin + Overwrite (TC_Chunked_String, 1, "abcdefghijklmn"); + Test (Report, Name, TC_Chunked_String, "abcdefghijklmn"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Delete"); + + + declare + Name : constant String := "Empty deletion at the end"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Delete (Source => TC_Chunked_String, + From => Length (TC_Chunked_String), + Through => Length (TC_Chunked_String) - 1); + Test (Report, Name, TC_Chunked_String, "Test String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty deletion at the beginning"; + begin + Delete (TC_Chunked_String, 1, 0); + Test (Report, Name, TC_Chunked_String, "Test String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Prefix deletion"; + begin + Delete (TC_Chunked_String, 1, 5); + Test (Report, Name, TC_Chunked_String, "String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "1-character range deletion"; + begin + Delete (TC_Chunked_String, 3, 3); + Test (Report, Name, TC_Chunked_String, "Sting"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Trim"); + + + declare + Name : constant String := "Nothing to trim"; + begin + TC_Chunked_String := To_Chunked_String ("No Spaces"); + Trim (Source => TC_Chunked_String, Side => Ada.Strings.Both); + Test (Report, Name, TC_Chunked_String, "No Spaces"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Trim left but not right"; + begin + TC_Chunked_String := To_Chunked_String (" Leading Spaces "); + Trim (TC_Chunked_String, Ada.Strings.Left); + Test (Report, Name, TC_Chunked_String, "Leading Spaces "); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Trim right but not left"; + begin + TC_Chunked_String := To_Chunked_String (" Ending Spaces "); + Trim (TC_Chunked_String, Ada.Strings.Right); + Test (Report, Name, TC_Chunked_String, " Ending Spaces"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Trim on both sides"; + begin + TC_Chunked_String + := To_Chunked_String (" Spaces on both ends "); + Trim (TC_Chunked_String, Ada.Strings.Both); + Test (Report, Name, TC_Chunked_String, "Spaces on both ends"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Trim (with Character Set parameter)"); + + declare + Name : constant String := "Normal trim"; + begin + TC_Chunked_String := To_Chunked_String ("lowerCASEletters"); + Trim (Source => TC_Chunked_String, + Left => Ada.Strings.Maps.Constants.Lower_Set, + Right => Ada.Strings.Maps.Constants.Lower_Set); + Test (Report, Name, TC_Chunked_String, "CASE"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Nothing to trim"; + begin + TC_Chunked_String := To_Chunked_String ("lowerCASEletters"); + Trim (TC_Chunked_String, + Ada.Strings.Maps.Constants.Upper_Set, + Ada.Strings.Maps.Constants.Upper_Set); + Test (Report, Name, TC_Chunked_String, "lowerCASEletters"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Normal trim"; + begin + TC_Chunked_String := To_Chunked_String ("012abcdefghGFEDCBA789ab"); + Trim (TC_Chunked_String, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set); + Test (Report, Name, TC_Chunked_String, "ghG"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Head"); + + declare + Name : constant String := "Empty head"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Head (Source => TC_Chunked_String, + Count => 0, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, Null_Chunked_String); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Normal Head"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Head (Source => TC_Chunked_String, + Count => 4, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "Test"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "No-op Head"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Head (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String), + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "Test String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Head with padding"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Head (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String) + 4, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "Test String****"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty string with padding"; + begin + TC_Chunked_String := Null_Chunked_String; + Head (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String) + 3, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "***"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + + NT.Section (Report, "Procedure Tail"); + + declare + Name : constant String := "Empty tail"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Tail (Source => TC_Chunked_String, + Count => 0, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, Null_Chunked_String); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Normal tail"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Tail (Source => TC_Chunked_String, + Count => 6, + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "No-op tail"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Tail (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String), + Pad => '*'); + Test (Report, Name, TC_Chunked_String, "Test String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Tail with padding"; + begin + TC_Chunked_String := To_Chunked_String ("Test String"); + Tail (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String) + 5, + Pad => 'x'); + Test (Report, Name, TC_Chunked_String, "xxxxxTest String"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + + declare + Name : constant String := "Empty string with padding"; + begin + TC_Chunked_String := Null_Chunked_String; + Tail (Source => TC_Chunked_String, + Count => Length (TC_Chunked_String) + 3, + Pad => 'X'); + Test (Report, Name, TC_Chunked_String, "XXX"); + exception + when Error : others => NT.Report_Exception (Report, Name, Error); + end; + + NT.End_Section (Report); + exception + when Error : others => + NT.Report_Exception (Report, "Preparation", Error); + end; + + NT.End_Section (Report); + +end Natools.Chunked_Strings.Tests.CXA4032; ADDED tests/natools-chunked_strings-tests-cxa4032.ads Index: tests/natools-chunked_strings-tests-cxa4032.ads ================================================================== --- tests/natools-chunked_strings-tests-cxa4032.ads +++ tests/natools-chunked_strings-tests-cxa4032.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests.CXA4032 is the transcription to -- +-- Chunked_String of ACATS test CXA4032 for Unbounded_String. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic procedure Natools.Chunked_Strings.Tests.CXA4032 + (Report : in out Natools.Tests.Reporter'Class); +pragma Preelaborate (CXA4032); ADDED tests/natools-chunked_strings-tests.adb Index: tests/natools-chunked_strings-tests.adb ================================================================== --- tests/natools-chunked_strings-tests.adb +++ tests/natools-chunked_strings-tests.adb @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Natools.Chunked_Strings.Tests.CXA4010; +with Natools.Chunked_Strings.Tests.CXA4011; +with Natools.Chunked_Strings.Tests.CXA4030; +with Natools.Chunked_Strings.Tests.CXA4031; +with Natools.Chunked_Strings.Tests.CXA4032; + +package body Natools.Chunked_Strings.Tests is + package NT renames Natools.Tests; + + procedure All_Blackbox_Tests (Report : in out Natools.Tests.Reporter'Class) + is + procedure Test_CXA4010 is new CXA4010; + procedure Test_CXA4011 is new CXA4011; + procedure Test_CXA4030 is new CXA4030; + procedure Test_CXA4031 is new CXA4031; + procedure Test_CXA4032 is new CXA4032; + begin + NT.Section (Report, "Blackbox tests of Chunked_Strings"); + Test_CXA4010 (Report); + Test_CXA4011 (Report); + Test_CXA4030 (Report); + Test_CXA4031 (Report); + Test_CXA4032 (Report); + NT.End_Section (Report); + end All_Blackbox_Tests; + + + procedure All_Tests (Report : in out Natools.Tests.Reporter'Class) is + begin + NT.Section (Report, "All tests of Chunked_Strings"); + All_Blackbox_Tests (Report); + NT.End_Section (Report); + end All_Tests; + + + + procedure Dump (Report : in out Natools.Tests.Reporter'Class; + Dumped : in Chunked_String) + is + package Maps renames Ada.Strings.Maps; + use type Maps.Character_Set; + + procedure Print_Chunk (Index : Positive; Chunk : String_Access); + procedure Print_Chunks (Data : Chunk_Array_Access); + procedure Print_Line (Raw : String); + + Printable : constant Maps.Character_Set + := Maps.To_Set (Maps.Character_Ranges'((Low => 'a', High => 'z'), + (Low => 'A', High => 'Z'), + (Low => '0', High => '9'))) + or Maps.To_Set (" -_"); + Non_Printable : constant Character := '.'; + + procedure Print_Chunk (Index : Positive; Chunk : String_Access) is + I : Natural; + begin + if Chunk = null then + NT.Info (Report, "Chunk" & Positive'Image (Index) & ": null"); + else + NT.Info (Report, "Chunk" & Positive'Image (Index) & ": " + & Natural'Image (Chunk.all'First) & " .." + & Natural'Image (Chunk.all'Last)); + I := Chunk.all'First; + while I <= Chunk.all'Last loop + Print_Line + (Chunk.all (I .. Positive'Min (Chunk.all'Last, I + 16))); + I := I + 16; + end loop; + end if; + end Print_Chunk; + + procedure Print_Chunks (Data : Chunk_Array_Access) is + begin + if Data = null then + NT.Info (Report, "Null data"); + end if; + if Data.all'Length = 0 then + NT.Info (Report, "Empty data"); + end if; + for C in Data.all'Range loop + Print_Chunk (C, Data.all (C)); + end loop; + end Print_Chunks; + + procedure Print_Line (Raw : String) is + Hex : constant String := "0123456789ABCDEF"; + Line : String (1 .. 4 * Raw'Length + 2) := (others => ' '); + begin + for I in Raw'Range loop + declare + Pos : constant Natural := Character'Pos (Raw (I)); + High : constant Natural := (Pos - 1) / 16; + Low : constant Natural := (Pos - 1) mod 16; + Hex_Base : constant Positive + := Line'First + 3 * (I - Raw'First); + Raw_Base : constant Positive + := Line'First + 3 * Raw'Length + 2 + (I - Raw'First); + begin + Line (Hex_Base) := Hex (Hex'First + High); + Line (Hex_Base + 1) := Hex (Hex'First + Low); + if Maps.Is_In (Raw (I), Printable) then + Line (Raw_Base) := Raw (I); + else + Line (Raw_Base) := Non_Printable; + end if; + end; + end loop; + NT.Info (Report, Line); + end Print_Line; + begin + NT.Info (Report, "Chunk_Size " & Positive'Image (Dumped.Chunk_Size) + & " (default" & Positive'Image (Default_Chunk_Size) + & ')'); + NT.Info (Report, "Allocation_Unit " + & Positive'Image (Dumped.Allocation_Unit) + & " (default" & Positive'Image (Default_Allocation_Unit) + & ')'); + NT.Info (Report, "Size " & Natural'Image (Dumped.Size)); + Print_Chunks (Dumped.Data); + end Dump; + + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Chunked_String; + Reference : in String) is + begin + if not Is_Valid (Computed) then + NT.Item (Report, Test_Name, NT.Error); + return; + end if; + if Computed = To_Chunked_String (Reference) then + NT.Item (Report, Test_Name, NT.Success); + else + NT.Item (Report, Test_Name, NT.Fail); + NT.Info (Report, "Computed """ & To_String (Computed) & '"'); + NT.Info (Report, "Reference """ & Reference & '"'); + end if; + end Test; + + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Chunked_String; + Reference : in Chunked_String) is + begin + if not Is_Valid (Computed) then + NT.Item (Report, Test_Name, NT.Error); + return; + end if; + if not Is_Valid (Reference) then + NT.Item (Report, Test_Name, NT.Error); + return; + end if; + if Computed = Reference then + NT.Item (Report, Test_Name, NT.Success); + else + NT.Item (Report, Test_Name, NT.Fail); + NT.Info (Report, "Computed """ & To_String (Computed) & '"'); + NT.Info (Report, "Reference """ & To_String (Reference) & '"'); + end if; + end Test; + + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Natural; + Reference : in Natural) is + begin + if Computed = Reference then + NT.Item (Report, Test_Name, NT.Success); + else + NT.Item (Report, Test_Name, NT.Fail); + NT.Info (Report, "Computed" & Natural'Image (Computed) + & ", expected" & Natural'Image (Reference)); + end if; + end Test; + +end Natools.Chunked_Strings.Tests; ADDED tests/natools-chunked_strings-tests.ads Index: tests/natools-chunked_strings-tests.ads ================================================================== --- tests/natools-chunked_strings-tests.ads +++ tests/natools-chunked_strings-tests.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Chunked_Strings.Tests is the test suite for Chunked_String. -- +-- -- +-- It currently contains only black-box tests (i.e. without any assumption -- +-- on the internal implementaiton), taken from Unbounded_String tests in -- +-- ACATS. -- +-- -- +-- It also provides private helper functions used in more specialized test -- +-- packages. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +generic package Natools.Chunked_Strings.Tests is + pragma Preelaborate (Tests); + + procedure All_Blackbox_Tests (Report : in out Natools.Tests.Reporter'Class); + + procedure All_Tests (Report : in out Natools.Tests.Reporter'Class); + +private + + procedure Dump (Report : in out Natools.Tests.Reporter'Class; + Dumped : in Chunked_String); + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Chunked_String; + Reference : in String); + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Chunked_String; + Reference : in Chunked_String); + + procedure Test (Report : in out Natools.Tests.Reporter'Class; + Test_Name : in String; + Computed : in Natural; + Reference : in Natural); + +end Natools.Chunked_Strings.Tests; ADDED tests/natools-getopt_long_tests.adb Index: tests/natools-getopt_long_tests.adb ================================================================== --- tests/natools-getopt_long_tests.adb +++ tests/natools-getopt_long_tests.adb @@ -0,0 +1,835 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Indefinite_Vectors; +with Ada.Exceptions; +with Ada.Strings.Unbounded; +with Natools.Getopt_Long; + +package body Natools.Getopt_Long_Tests is + + package US renames Ada.Strings.Unbounded; + + ---------------------------------------- + -- Dynamic command line argument list -- + ---------------------------------------- + + package String_Vectors is new Ada.Containers.Indefinite_Vectors + (Index_Type => Positive, Element_Type => String); + + Command_Line : String_Vectors.Vector; + + + function Argument_Count return Natural; + function Argument (Number : Positive) return String; + + + function Argument_Count return Natural is + begin + return Natural (Command_Line.Length); + end Argument_Count; + + function Argument (Number : Positive) return String is + begin + return Command_Line.Element (Number); + end Argument; + + + + -------------------------------- + -- Arguments used for testing -- + -------------------------------- + + type Option_Id is + (Short_No_Arg, Short_No_Arg_2, Short_Opt_Arg, Short_Arg, + Long_No_Arg, Long_Opt_Arg, Long_Arg, Long_Ambiguous, + Mixed_No_Arg, Mixed_Opt_Arg, Mixed_Arg, + Command_Argument); + + type Flag_Seen_Array is array (Option_Id) of Boolean; + + type Flag_Argument_Array is array (Option_Id) of US.Unbounded_String; + + Separator : constant Character := ';'; + + package Getopt is new Natools.Getopt_Long (Option_Id); + + function Getopt_Config + (Posixly_Correct, Long_Only : Boolean) + return Getopt.Configuration; + -- Create the Getopt.Configuration object used for these tests. + + + function Getopt_Config + (Posixly_Correct, Long_Only : Boolean) + return Getopt.Configuration is + begin + return OD : Getopt.Configuration do + OD.Add_Option ('a', Getopt.No_Argument, Short_No_Arg); + OD.Add_Option ('q', Getopt.No_Argument, Short_No_Arg_2); + OD.Add_Option ('f', Getopt.Required_Argument, Short_Arg); + OD.Add_Option ('v', Getopt.Optional_Argument, Short_Opt_Arg); + OD.Add_Option ("aq", Getopt.No_Argument, Long_Ambiguous); + OD.Add_Option ("aquatic", Getopt.No_Argument, Long_No_Arg); + OD.Add_Option ("color", Getopt.Optional_Argument, Long_Opt_Arg); + OD.Add_Option ("input", Getopt.Required_Argument, Long_Arg); + OD.Add_Option ("execute", 'e', Getopt.Required_Argument, Mixed_Arg); + OD.Add_Option ("ignore-case", 'i', Getopt.No_Argument, Mixed_No_Arg); + OD.Add_Option ("write", 'w', Getopt.Optional_Argument, Mixed_Opt_Arg); + OD.Posixly_Correct (Posixly_Correct); + OD.Use_Long_Only (Long_Only); + end return; + end Getopt_Config; + + + + ------------------- + -- Test Handlers -- + ------------------- + + package Handlers is + + type Basic is new Getopt.Handlers.Callback with record + Flag_Seen : Flag_Seen_Array := (others => False); + Flag_Argument : Flag_Argument_Array; + Flag_Error : String_Vectors.Vector; + end record; + + overriding + procedure Option (Handler : in out Basic; + Id : Option_Id; + Argument : String); + -- Process the given option, by recording it as seen in Flag_Seen + -- and appending the argument to Flag_Argument. + + overriding + procedure Argument (Handler : in out Basic; + Argument : String); + -- Process the given argument, by recording it + -- in Flag_Seen (Command_Argument) and appending it + -- to Flag_Argument (Command_Argument). + + not overriding + procedure Dump (Handler : Basic; + Report : in out NT.Reporter'Class); + -- Dump the current state (Flag_* variables) into the Report. + + + type Error_Count is record + Missing_Argument_Long : Natural := 0; + Missing_Argument_Short : Natural := 0; + Unexpected_Argument : Natural := 0; + Unknown_Long_Option : Natural := 0; + Unknown_Short_Option : Natural := 0; + end record; + + type Recovering is new Basic with record + Count : Error_Count; + end record; + + procedure Increment (Number : in out Natural); + + overriding + procedure Missing_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name); + + overriding + procedure Unexpected_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name; + Argument : String); + + overriding + procedure Unknown_Option + (Handler : in out Recovering; + Name : Getopt.Any_Name); + + end Handlers; + + + + package body Handlers is + + overriding + procedure Option (Handler : in out Basic; + Id : Option_Id; + Argument : String) is + begin + Handler.Flag_Seen (Id) := True; + US.Append (Handler.Flag_Argument (Id), Argument & Separator); + end Option; + + + overriding + procedure Argument (Handler : in out Basic; + Argument : String) is + begin + Option (Handler, Command_Argument, Argument); + end Argument; + + + not overriding + procedure Dump (Handler : Basic; + Report : in out NT.Reporter'Class) + is + procedure Process (Position : String_Vectors.Cursor); + function Seen_String (Seen : Boolean) return String; + + procedure Process (Position : String_Vectors.Cursor) is + begin + Report.Info ("Error """ & String_Vectors.Element (Position) & '"'); + end Process; + + function Seen_String (Seen : Boolean) return String is + begin + if Seen then + return "Seen"; + else + return "Not seen"; + end if; + end Seen_String; + begin + Report.Info ("Flags:"); + for Id in Option_Id loop + Report.Info (" " + & Option_Id'Image (Id) & ": " + & Seen_String (Handler.Flag_Seen (Id)) & ", """ + & US.To_String (Handler.Flag_Argument (Id)) & '"'); + end loop; + Handler.Flag_Error.Iterate (Process'Access); + end Dump; + + + procedure Increment (Number : in out Natural) is + begin + Number := Number + 1; + end Increment; + + + overriding + procedure Missing_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name) + is + pragma Unreferenced (Id); + begin + case Name.Style is + when Getopt.Short => + Increment (Handler.Count.Missing_Argument_Short); + when Getopt.Long => + Increment (Handler.Count.Missing_Argument_Long); + end case; + end Missing_Argument; + + overriding + procedure Unexpected_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name; + Argument : String) + is + pragma Unreferenced (Id); + pragma Unreferenced (Name); + pragma Unreferenced (Argument); + begin + Increment (Handler.Count.Unexpected_Argument); + end Unexpected_Argument; + + + overriding + procedure Unknown_Option + (Handler : in out Recovering; + Name : Getopt.Any_Name) is + begin + case Name.Style is + when Getopt.Short => + Increment (Handler.Count.Unknown_Short_Option); + when Getopt.Long => + Increment (Handler.Count.Unknown_Long_Option); + end case; + end Unknown_Option; + + end Handlers; + + + + ---------------------------- + -- Generic test procedure -- + ---------------------------- + + procedure Test + (Report : in out NT.Reporter'Class; + Name : String; + Expected_Seen : Flag_Seen_Array; + Expected_Argument : Flag_Argument_Array; + Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector; + Posixly_Correct : Boolean := True; + Long_Only : Boolean := False); + + + procedure Test + (Report : in out NT.Reporter'Class; + Name : String; + Expected_Seen : Flag_Seen_Array; + Expected_Argument : Flag_Argument_Array; + Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector; + Posixly_Correct : Boolean := True; + Long_Only : Boolean := False) + is + use type String_Vectors.Vector; + Config : constant Getopt.Configuration + := Getopt_Config (Posixly_Correct, Long_Only); + Handler : Handlers.Basic; + begin + begin + Getopt.Process + (Config => Config, + Handler => Handler, + Argument_Count => Argument_Count'Access, + Argument => Argument'Access); + exception + when Error : Getopt.Option_Error => + Handler.Flag_Error.Append + (Ada.Exceptions.Exception_Message (Error)); + end; + + if Handler.Flag_Seen = Expected_Seen and + Handler.Flag_Argument = Expected_Argument and + Handler.Flag_Error = Expected_Error + then + Report.Item (Name, NT.Success); + else + Report.Item (Name, NT.Fail); + Handler.Dump (Report); + end if; + exception + when Error : others => + Report.Report_Exception (Name, Error); + Handler.Dump (Report); + end Test; + + + + --------------------------- + -- Public test functions -- + --------------------------- + + procedure All_Tests (Report : in out NT.Reporter'Class) is + begin + Test_Arguments (Report); + Test_Empty (Report); + Test_Error_Callbacks (Report); + Test_Everything (Report); + Test_Long (Report); + Test_Long_Only (Report); + Test_Long_Partial (Report); + Test_Long_Partial_Ambiguous (Report); + Test_Missing_Argument_Long (Report); + Test_Missing_Argument_Short (Report); + Test_Mixed_Arg (Report); + Test_Mixed_No_Arg (Report); + Test_Posixly_Correct (Report); + Test_Short_Argument (Report); + Test_Short_Compact (Report); + Test_Short_Expanded (Report); + Test_Unexpected_Argument (Report); + Test_Unknown_Long (Report); + Test_Unknown_Short (Report); + end All_Tests; + + + procedure Test_Arguments (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("Argument 1"); + Command_Line.Append ("Argument 2"); + Command_Line.Append ("Argument 3"); + Test (Report, "Arguments without flag", + (Command_Argument => True, + others => False), + (Command_Argument + => US.To_Unbounded_String ("Argument 1;Argument 2;Argument 3;"), + others => US.Null_Unbounded_String)); + end Test_Arguments; + + + procedure Test_Empty (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Test (Report, "Empty command line", + (others => False), + (others => US.Null_Unbounded_String)); + end Test_Empty; + + + procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class) is + procedure Local_Test + (Name : String; + Expected_Seen : Flag_Seen_Array; + Expected_Argument : Flag_Argument_Array; + Expected_Count : Handlers.Error_Count); + + + procedure Local_Test + (Name : String; + Expected_Seen : Flag_Seen_Array; + Expected_Argument : Flag_Argument_Array; + Expected_Count : Handlers.Error_Count) + is + use type Handlers.Error_Count; + Config : constant Getopt.Configuration := Getopt_Config (True, False); + Handler : Handlers.Recovering; + begin + Getopt.Process + (Config => Config, + Handler => Handler, + Argument_Count => Argument_Count'Access, + Argument => Argument'Access); + if Handler.Count /= Expected_Count then + Report.Item (Name, NT.Fail); + if Handler.Count.Missing_Argument_Long + /= Expected_Count.Missing_Argument_Long + then + Report.Info ("Missing argument to long option callback called" + & Natural'Image (Handler.Count.Missing_Argument_Long) + & " times, expected" + & Natural'Image (Expected_Count.Missing_Argument_Long)); + end if; + if Handler.Count.Missing_Argument_Short + /= Expected_Count.Missing_Argument_Short + then + Report.Info ("Missing argument to short option callback called" + & Natural'Image (Handler.Count.Missing_Argument_Short) + & " times, expected" + & Natural'Image (Expected_Count.Missing_Argument_Short)); + end if; + if Handler.Count.Unexpected_Argument + /= Expected_Count.Unexpected_Argument + then + Report.Info ("Unexpected argument callback called" + & Natural'Image (Handler.Count.Unexpected_Argument) + & " times, expected" + & Natural'Image (Expected_Count.Unexpected_Argument)); + end if; + if Handler.Count.Unknown_Long_Option + /= Expected_Count.Unknown_Long_Option + then + Report.Info ("Unknown long option callback called" + & Natural'Image (Handler.Count.Unknown_Long_Option) + & " times, expected" + & Natural'Image (Expected_Count.Unknown_Long_Option)); + end if; + if Handler.Count.Unknown_Short_Option + /= Expected_Count.Unknown_Short_Option + then + Report.Info ("Unknown short option callback called" + & Natural'Image (Handler.Count.Unknown_Short_Option) + & " times, expected" + & Natural'Image (Expected_Count.Unknown_Short_Option)); + end if; + elsif Handler.Flag_Seen /= Expected_Seen or + Handler.Flag_Argument /= Expected_Argument + then + Report.Item (Name, NT.Fail); + Handler.Dump (Report); + else + Report.Item (Name, NT.Success); + end if; + exception + when Error : others => + Report.Report_Exception (Name, Error); + Handler.Dump (Report); + end Local_Test; + begin + Report.Section ("Error-handling callbacks"); + + Command_Line.Clear; + Command_Line.Append ("-af"); + Local_Test ("Missing argument for short option", + (Short_No_Arg => True, others => False), + (Short_No_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + (Missing_Argument_Short => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("--color"); + Command_Line.Append ("--input"); + Local_Test ("Missing argument for long option", + (Long_Opt_Arg => True, others => False), + (Long_Opt_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + (Missing_Argument_Long => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("--aquatic=extra"); + Local_Test ("Unexpected argument", + (others => False), + (others => US.Null_Unbounded_String), + (Unexpected_Argument => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("-a"); + Command_Line.Append ("--ignore-case=true"); + Command_Line.Append ("--execute"); + Command_Line.Append ("command"); + Command_Line.Append ("file"); + Local_Test ("Process continues after caught unexpected argument", + (Short_No_Arg | Mixed_Arg | Command_Argument => True, + others => False), + (Short_No_Arg => US.To_Unbounded_String (";"), + Mixed_Arg => US.To_Unbounded_String ("command;"), + Command_Argument => US.To_Unbounded_String ("file;"), + others => US.Null_Unbounded_String), + (Unexpected_Argument => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("-abqffoo"); + Local_Test ("Unknown short option", + (Short_No_Arg | Short_No_Arg_2 | Short_Arg => True, + others => False), + (Short_No_Arg => US.To_Unbounded_String (";"), + Short_No_Arg_2 => US.To_Unbounded_String (";"), + Short_Arg => US.To_Unbounded_String ("foo;"), + others => US.Null_Unbounded_String), + (Unknown_Short_Option => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("--execute"); + Command_Line.Append ("command"); + Command_Line.Append ("--unknown=argument"); + Command_Line.Append ("file"); + Local_Test ("Unknown long option", + (Mixed_Arg | Command_Argument => True, others => False), + (Mixed_Arg => US.To_Unbounded_String ("command;"), + Command_Argument => US.To_Unbounded_String ("file;"), + others => US.Null_Unbounded_String), + (Unknown_Long_Option => 1, others => 0)); + + Command_Line.Clear; + Command_Line.Append ("--ignore-case"); + Command_Line.Append ("-bffoo"); + Command_Line.Append ("--aq=unexpected"); + Command_Line.Append ("-ecommand"); + Command_Line.Append ("--unknown"); + Command_Line.Append ("--input"); + Local_Test ("All errors simultaneously", + (Short_Arg | Mixed_No_Arg | Mixed_Arg => True, + others => False), + (Short_Arg => US.To_Unbounded_String ("foo;"), + Mixed_Arg => US.To_Unbounded_String ("command;"), + Mixed_No_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + (Missing_Argument_Long => 1, + Missing_Argument_Short => 0, + Unexpected_Argument => 1, + Unknown_Long_Option => 1, + Unknown_Short_Option => 1)); + + Report.End_Section; + end Test_Error_Callbacks; + + + procedure Test_Everything (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--write=arg 1"); + Command_Line.Append ("-awvfarg 2"); + Command_Line.Append ("--aq"); + Command_Line.Append ("-e"); + Command_Line.Append ("arg 3"); + Command_Line.Append ("--ignore-case"); + Command_Line.Append ("--color=arg 4"); + Command_Line.Append ("-iv"); + Command_Line.Append ("--execute=arg 5"); + Command_Line.Append ("--color"); + Command_Line.Append ("--input"); + Command_Line.Append ("arg 6"); + Command_Line.Append ("arg 7"); + Command_Line.Append ("arg 8"); + Test (Report, "Everything together", + (Short_No_Arg_2 | Long_No_Arg => False, others => True), + (Short_No_Arg => US.To_Unbounded_String (";"), + Short_No_Arg_2 => US.Null_Unbounded_String, + Short_Arg => US.To_Unbounded_String ("arg 2;"), + Short_Opt_Arg => US.To_Unbounded_String (";;"), + Long_Ambiguous => US.To_Unbounded_String (";"), + Long_No_Arg => US.Null_Unbounded_String, + Long_Opt_Arg => US.To_Unbounded_String ("arg 4;;"), + Long_Arg => US.To_Unbounded_String ("arg 6;"), + Mixed_Arg => US.To_Unbounded_String ("arg 3;arg 5;"), + Mixed_No_Arg => US.To_Unbounded_String (";;"), + Mixed_Opt_Arg => US.To_Unbounded_String ("arg 1;;"), + Command_Argument => US.To_Unbounded_String ("arg 7;arg 8;"))); + end Test_Everything; + + + procedure Test_Long (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--aquatic"); + Command_Line.Append ("--input=i equal"); + Command_Line.Append ("--color=c equal"); + Command_Line.Append ("--input"); + Command_Line.Append ("i space"); + Command_Line.Append ("--color"); + Command_Line.Append ("c space"); + Command_Line.Append ("top level"); + Test (Report, "Long flags", + (Long_No_Arg | Long_Opt_Arg | Long_Arg | Command_Argument => True, + others => False), + (Long_No_Arg => US.To_Unbounded_String (";"), + Long_Opt_Arg => US.To_Unbounded_String ("c equal;;"), + Long_Arg => US.To_Unbounded_String ("i equal;i space;"), + Command_Argument => US.To_Unbounded_String ("c space;top level;"), + others => US.Null_Unbounded_String)); + end Test_Long; + + + procedure Test_Long_Only (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-aq"); + -- Can be either 'a' and 'q' short flags or "aq" long flag, depending + -- on Long_Only parameter + + -- Without Long_Only (default) + Test (Report, "Long_Only disabled (default)", + (Short_No_Arg | Short_No_Arg_2 => True, others => False), + (Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + Long_Only => False); + + -- With Long_Only + Test (Report, "Long_Only enabled", + (Long_Ambiguous => True, others => False), + (Long_Ambiguous => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + Long_Only => True); + end Test_Long_Only; + + + procedure Test_Long_Partial (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--aqu"); + Command_Line.Append ("--co=foo"); + Command_Line.Append ("--in"); + Command_Line.Append ("bar"); + Test (Report, "Partial matches for long flags", + (Long_No_Arg | Long_Opt_Arg | Long_Arg => True, others => False), + (Long_No_Arg => US.To_Unbounded_String (";"), + Long_Opt_Arg => US.To_Unbounded_String ("foo;"), + Long_Arg => US.To_Unbounded_String ("bar;"), + others => US.Null_Unbounded_String)); + end Test_Long_Partial; + + + procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--i"); + -- partial match for both "input" and "ignore-case" long flags + Test (Report, "Ambiguous partial match for long flags", + (others => False), + (others => US.Null_Unbounded_String), + String_Vectors.To_Vector ("Unknown option --i", 1)); + + Command_Line.Clear; + Command_Line.Append ("--aq"); + -- partial match for both "aq" and "aquatic" long flags + -- but exact match is preferred + Test (Report, "Ambiguous exact match for long flags", + (Long_Ambiguous => True, others => False), + (Long_Ambiguous => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String)); + end Test_Long_Partial_Ambiguous; + + + procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--color"); + Command_Line.Append ("--input"); + Test (Report, "Missing argument for long option", + (Long_Opt_Arg => True, others => False), + (Long_Opt_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + String_Vectors.To_Vector + ("Missing argument to option --input", 1)); + end Test_Missing_Argument_Long; + + + procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-v"); + Command_Line.Append ("-f"); + Test (Report, "Missing argument for long option", + (Short_Opt_Arg => True, others => False), + (Short_Opt_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String), + String_Vectors.To_Vector ("Missing argument to option -f", 1)); + end Test_Missing_Argument_Short; + + + procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-efoo"); + Command_Line.Append ("-qe"); + Command_Line.Append ("bar"); + Command_Line.Append ("-aebaz"); + Command_Line.Append ("--execute=long"); + Test (Report, "Short and long options with arguments", + (Mixed_Arg | Short_No_Arg | Short_No_Arg_2 => True, + others => False), + (Mixed_Arg => US.To_Unbounded_String ("foo;bar;baz;long;"), + Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String)); + end Test_Mixed_Arg; + + + procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-ai"); + Command_Line.Append ("--ignore-case"); + Test (Report, "Short and long options without arguments", + (Mixed_No_Arg | Short_No_Arg => True, others => False), + (Mixed_No_Arg => US.To_Unbounded_String (";;"), + Short_No_Arg => US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String)); + end Test_Mixed_No_Arg; + + + procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-a"); + Command_Line.Append ("top level"); + Command_Line.Append ("-q"); + -- Posixly_Correct defines whether this "-q" is a top-level argument + -- or a short flag + + -- With the flag + Test (Report, "Posixly correct behavior", + (Short_No_Arg | Command_Argument => True, + others => False), + (Short_No_Arg => US.To_Unbounded_String (";"), + Command_Argument => US.To_Unbounded_String ("top level;-q;"), + others => US.Null_Unbounded_String), + Posixly_Correct => True); + + -- Without the flag + Test (Report, "GNU (posixly incorrect) behavior", + (Short_No_Arg | Short_No_Arg_2 | Command_Argument => True, + others => False), + (Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"), + Command_Argument => US.To_Unbounded_String ("top level;"), + others => US.Null_Unbounded_String), + Posixly_Correct => False); + end Test_Posixly_Correct; + + + procedure Test_Short_Argument (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-faq"); + -- "aq" is argument for 'f' short flag, not 'a' and 'q' short flags + Command_Line.Append ("-f"); + Command_Line.Append ("-a"); + -- "-a" is argument for 'f' short flag, not 'a' short flag + Command_Line.Append ("-v"); + Command_Line.Append ("bar"); + -- "bar" is top level argument, because optional argument for short + -- flags are never set + Test (Report, "Arguments to short flags", + (Short_Arg | Short_Opt_Arg | Command_Argument => True, + others => False), + (Short_Arg => US.To_Unbounded_String ("aq;-a;"), + Short_Opt_Arg => US.To_Unbounded_String (";"), + Command_Argument => US.To_Unbounded_String ("bar;"), + others => US.Null_Unbounded_String)); + end Test_Short_Argument; + + + procedure Test_Short_Compact (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-avq"); + -- "q" is not argument to 'v' short flag, but a short flag itself + Test (Report, "Argumentless compact short flags", + (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True, + others => False), + (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => + US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String)); + end Test_Short_Compact; + + + procedure Test_Short_Expanded (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-a"); + Command_Line.Append ("-v"); + Command_Line.Append ("-q"); + Test (Report, "Argumentless expanded short flags", + (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True, + others => False), + (Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => + US.To_Unbounded_String (";"), + others => US.Null_Unbounded_String)); + end Test_Short_Expanded; + + + procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--color=foo"); + Command_Line.Append ("--aq=bar"); + Test (Report, "Unexpected argument to long option", + (Long_Opt_Arg => True, others => False), + (Long_Opt_Arg => US.To_Unbounded_String ("foo;"), + others => US.Null_Unbounded_String), + String_Vectors.To_Vector + ("Unexpected argument ""bar"" to option --aq", 1)); + end Test_Unexpected_Argument; + + + procedure Test_Unknown_Long (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("--long-flag"); + Test (Report, "Unknown long flag", + (others => False), (others => US.Null_Unbounded_String), + String_Vectors.To_Vector ("Unknown option --long-flag", 1)); + end Test_Unknown_Long; + + + procedure Test_Unknown_Short (Report : in out NT.Reporter'Class) is + begin + Command_Line.Clear; + Command_Line.Append ("-g"); + Test (Report, "Unknown short flag", + (others => False), (others => US.Null_Unbounded_String), + String_Vectors.To_Vector ("Unknown option -g", 1)); + end Test_Unknown_Short; + +end Natools.Getopt_Long_Tests; ADDED tests/natools-getopt_long_tests.ads Index: tests/natools-getopt_long_tests.ads ================================================================== --- tests/natools-getopt_long_tests.ads +++ tests/natools-getopt_long_tests.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.Getopt_Long_Tests is a test suite for Natools.Getopt_Long -- +-- command-line argument processing facilities. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +package Natools.Getopt_Long_Tests is + pragma Preelaborate (Getopt_Long_Tests); + + package NT renames Natools.Tests; + + procedure All_Tests (Report : in out NT.Reporter'Class); + + procedure Test_Arguments (Report : in out NT.Reporter'Class); + procedure Test_Empty (Report : in out NT.Reporter'Class); + procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class); + procedure Test_Everything (Report : in out NT.Reporter'Class); + procedure Test_Long (Report : in out NT.Reporter'Class); + procedure Test_Long_Only (Report : in out NT.Reporter'Class); + procedure Test_Long_Partial (Report : in out NT.Reporter'Class); + procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class); + procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class); + procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class); + procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class); + procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class); + procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class); + procedure Test_Short_Argument (Report : in out NT.Reporter'Class); + procedure Test_Short_Compact (Report : in out NT.Reporter'Class); + procedure Test_Short_Expanded (Report : in out NT.Reporter'Class); + procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class); + procedure Test_Unknown_Long (Report : in out NT.Reporter'Class); + procedure Test_Unknown_Short (Report : in out NT.Reporter'Class); + +end Natools.Getopt_Long_Tests; ADDED tests/test_all.adb Index: tests/test_all.adb ================================================================== --- tests/test_all.adb +++ tests/test_all.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2011, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +----------------------------------------------------------------------- +-- Test_All is a binary gathering all tests from Natools components. -- +----------------------------------------------------------------------- + +with Ada.Command_Line; +with Ada.Text_IO; +with Natools.Chunked_Strings.Tests; +with Natools.Getopt_Long_Tests; +with Natools.Tests.Text_IO; + +procedure Test_All is + package Uneven_Chunked_Strings is new Natools.Chunked_Strings + (Default_Allocation_Unit => 7, + Default_Chunk_Size => 15); + package Uneven_Chunked_Strings_Tests is new Uneven_Chunked_Strings.Tests; + + package Even_Chunked_Strings is new Natools.Chunked_Strings + (Default_Allocation_Unit => 6, + Default_Chunk_Size => 18); + package Even_Chunked_Strings_Tests is new Even_Chunked_Strings.Tests; + + package Single_Chunked_Strings is new Natools.Chunked_Strings + (Default_Allocation_Unit => 10, + Default_Chunk_Size => 10); + package Single_Chunked_Strings_Tests is new Single_Chunked_Strings.Tests; + + Report : Natools.Tests.Text_IO.Text_Reporter; +begin + Ada.Text_IO.Set_Line_Length (80); + Report.Section ("All Tests"); + + Report.Section ("Chunked_String with uneven allocation unit"); + Uneven_Chunked_Strings_Tests.All_Tests (Report); + Report.End_Section; + + Report.Section ("Chunked_String with even allocation unit"); + Even_Chunked_Strings_Tests.All_Tests (Report); + Report.End_Section; + + Report.Section ("Chunked_String with single allocation unit"); + Single_Chunked_Strings_Tests.All_Tests (Report); + Report.End_Section; + + Report.Section ("Getopt_Long"); + Natools.Getopt_Long_Tests.All_Tests (Report); + Report.End_Section; + + Natools.Tests.Text_IO.Print_Results (Report.Total_Results); + + declare + Results : constant Natools.Tests.Result_Summary := Report.Total_Results; + begin + if Results (Natools.Tests.Fail) > 0 or + Results (Natools.Tests.Error) > 0 + then + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + else + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Success); + end if; + end; + Report.End_Section; +end Test_All;