ADDED tests/natools-s_expressions-interpreter_tests.adb Index: tests/natools-s_expressions-interpreter_tests.adb ================================================================== --- tests/natools-s_expressions-interpreter_tests.adb +++ tests/natools-s_expressions-interpreter_tests.adb @@ -0,0 +1,364 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, 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.S_Expressions.Caches; +with Natools.S_Expressions.Test_Tools; + +package body Natools.S_Expressions.Interpreter_Tests is + + function Test_Interpreter return Test_Interpreters.Interpreter; + + function Invalid_Commands return Caches.Reference; + + + ------------------------ + -- Helper Subprograms -- + ------------------------ + + function Invalid_Commands return Caches.Reference is + Cache : Caches.Reference; + Short : constant Atom := To_Atom ("not-cmd"); + Long : constant Atom := To_Atom ("not-a-command"); + begin + Cache.Append_Atom (Short); + Cache.Open_List; + Cache.Append_Atom (Short); + Cache.Append_Atom (To_Atom ("arg")); + Cache.Close_List; + Cache.Append_Atom (Long); + Cache.Open_List; + Cache.Append_Atom (Long); + Cache.Open_List; + Cache.Close_List; + Cache.Close_List; + return Cache; + end Invalid_Commands; + + + function Test_Interpreter return Test_Interpreters.Interpreter is + Template : Recorder; + begin + return Inter : Test_Interpreters.Interpreter do + Inter.Add_Command (To_Atom ("cmd"), Template); + Inter.Add_Command (To_Atom ("command"), Template); + end return; + end Test_Interpreter; + + + + ---------------------- + -- Recorder Command -- + ---------------------- + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom) + is + pragma Unreferenced (Self); + begin + if Context then + State.Append_Atom (Name); + end if; + end Execute; + + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class) + is + pragma Unreferenced (Self); + begin + if not Context then + return; + end if; + + declare + Buffer : aliased Test_Tools.Memory_Stream; + Serializer : Printers.Canonical (Buffer'Access); + begin + Printers.Transfer (Cmd, Serializer); + State.Open_List; + State.Append_Atom (Buffer.Get_Data); + State.Close_List; + end; + end Execute; + + + + -------------------- + -- Raiser Command -- + -------------------- + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom) + is + pragma Unreferenced (Self, State, Context, Name); + begin + raise Special_Exception; + end Execute; + + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class) + is + pragma Unreferenced (Self, State, Context, Cmd); + begin + raise Special_Exception; + end Execute; + + + + ------------------------- + -- Complete Test Suite -- + ------------------------- + + procedure All_Tests (Report : in out NT.Reporter'Class) is + begin + Test_Basic_Usage (Report); + Test_Unknown_Commands (Report); + Test_Premanent_Fallback (Report); + Test_Local_Fallback (Report); + Test_Exception_Fallback (Report); + end All_Tests; + + + + ---------------------- + -- Individual Tests -- + ---------------------- + + procedure Test_Basic_Usage (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Basic usage"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference; + Cursor : Caches.Cursor; + begin + Input.Append_Atom (To_Atom ("cmd")); + Input.Open_List; + Input.Append_Atom (To_Atom ("cmd")); + Input.Append_Atom (To_Atom ("foo")); + Input.Append_Atom (To_Atom ("bar")); + Input.Close_List; + Input.Append_Atom (To_Atom ("command")); + Input.Open_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("comment")); + Input.Close_List; + Input.Close_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("command")); + Input.Open_List; + Input.Close_List; + Input.Close_List; + + Cursor := Input.First; + + Buffer.Set_Expected (To_Atom + ("3:cmd(15:3:cmd3:foo3:bar)7:command(11:7:command())")); + + Inter.Execute (Cursor, Printer, True); + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Basic_Usage; + + + procedure Test_Exception_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Local fallback raising an exception"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference; + Cursor : Caches.Cursor; + Fallback : Raiser; + begin + Input.Append_Atom (To_Atom ("cmd")); + Input.Open_List; + Input.Append_Atom (To_Atom ("unknown")); + Input.Append_Atom (To_Atom ("argument")); + Input.Close_List; + Input.Close_List; + Input.Open_List; + Input.Append_Atom (To_Atom ("command")); + Input.Close_List; + Cursor := Input.First; + + Buffer.Set_Expected (To_Atom ("3:cmd")); + + begin + Inter.Execute (Fallback, Cursor, Printer, True); + Test.Fail ("No exception raised"); + exception + when Special_Exception => null; + when Error : others => + Test.Fail ("Wrong exception raised:"); + Test.Report_Exception (Error, NT.Fail); + end; + + Buffer.Check_Stream (Test); + + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("argument"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("command"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.End_Of_Input, 0); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Exception_Fallback; + + + procedure Test_Local_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Local fallback"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + Fallback : Recorder; + begin + Input.Append_Atom (To_Atom ("cmd")); + Buffer.Set_Expected (To_Atom + ("7:not-cmd(14:7:not-cmd3:arg)13:not-a-command" + & "(18:13:not-a-command())3:cmd")); + + Inter.Execute (Fallback, Cursor, Printer, True); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Local_Fallback; + + + procedure Test_Premanent_Fallback (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Permanent fallback"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : constant Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + begin + Buffer.Set_Expected (To_Atom + ("7:not-cmd(14:7:not-cmd3:arg)13:not-a-command" + & "(18:13:not-a-command())")); + + Inter.Set_Fallback (To_Atom ("cmd")); + Inter.Execute (Cursor, Printer, True); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Premanent_Fallback; + + + procedure Test_Unknown_Commands (Report : in out NT.Reporter'Class) is + Test : NT.Test := Report.Item ("Unknown commands"); + begin + declare + Inter : Test_Interpreters.Interpreter := Test_Interpreter; + Buffer : aliased Test_Tools.Memory_Stream; + Printer : Printers.Canonical (Buffer'Access); + Input : constant Caches.Reference := Invalid_Commands; + Cursor : Caches.Cursor := Input.First; + begin + Inter.Set_Fallback (To_Atom ("cmd")); + Inter.Reset_Fallback; + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-cmd"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-cmd"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after (not-cmd)"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after (not-cmd)"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, To_Atom ("arg"), 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check + (Test, Cursor, To_Atom ("not-a-command"), 0); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-a-command"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-a-command"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 1); + + begin + Inter.Execute (Cursor, Printer, True); + Test.Fail ("No exception raised after not-a-command"); + exception + when Test_Interpreters.Command_Not_Found => null; + when Error : others => + Test.Fail ("Unexpected exception raised after not-a-command"); + Test.Report_Exception (Error, NT.Fail); + end; + + Test_Tools.Next_And_Check (Test, Cursor, Events.Open_List, 2); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 1); + Test_Tools.Next_And_Check (Test, Cursor, Events.Close_List, 0); + Test_Tools.Next_And_Check (Test, Cursor, Events.End_Of_Input, 0); + + Buffer.Check_Stream (Test); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Test_Unknown_Commands; + +end Natools.S_Expressions.Interpreter_Tests; ADDED tests/natools-s_expressions-interpreter_tests.ads Index: tests/natools-s_expressions-interpreter_tests.ads ================================================================== --- tests/natools-s_expressions-interpreter_tests.ads +++ tests/natools-s_expressions-interpreter_tests.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2014, 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.S_Expressions.Interpreter_Tests provides a test suite for -- +-- S-expression interpreters. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +private with Natools.S_Expressions.Interpreters; +private with Natools.S_Expressions.Lockable; +private with Natools.S_Expressions.Printers; + +package Natools.S_Expressions.Interpreter_Tests is + pragma Preelaborate (Interpreter_Tests); + + package NT renames Natools.Tests; + + procedure All_Tests (Report : in out NT.Reporter'Class); + + procedure Test_Basic_Usage (Report : in out NT.Reporter'Class); + procedure Test_Exception_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Local_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Premanent_Fallback (Report : in out NT.Reporter'Class); + procedure Test_Unknown_Commands (Report : in out NT.Reporter'Class); + +private + + package Test_Interpreters is new Natools.S_Expressions.Interpreters + (Printers.Printer'Class, Boolean); + + type Recorder is new Test_Interpreters.Command with null record; + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom); + + overriding procedure Execute + (Self : in out Recorder; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class); + + Special_Exception : exception; + + type Raiser is new Test_Interpreters.Command with null record; + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Name : in Atom); + + overriding procedure Execute + (Self : in out Raiser; + State : in out Printers.Printer'Class; + Context : in Boolean; + Cmd : in out Lockable.Descriptor'Class); + +end Natools.S_Expressions.Interpreter_Tests; Index: tests/test_all.adb ================================================================== --- tests/test_all.adb +++ tests/test_all.adb @@ -24,10 +24,11 @@ with Natools.Getopt_Long_Tests; with Natools.Reference_Tests; with Natools.S_Expressions.Atom_Buffers.Tests; with Natools.S_Expressions.Cache_Tests; with Natools.S_Expressions.Encodings.Tests; +with Natools.S_Expressions.Interpreter_Tests; with Natools.S_Expressions.Lockable.Tests; with Natools.S_Expressions.Parsers.Tests; with Natools.S_Expressions.Printers.Tests; with Natools.S_Expressions.Printers.Pretty.Tests; with Natools.String_Slice_Set_Tests; @@ -84,10 +85,14 @@ Report.End_Section; Report.Section ("S_Expressions.Encodings"); Natools.S_Expressions.Encodings.Tests.All_Tests (Report); Report.End_Section; + + Report.Section ("S_Expressions.Interpreters"); + Natools.S_Expressions.Interpreter_Tests.All_Tests (Report); + Report.End_Section; Report.Section ("S_Expressions.Lockable"); Natools.S_Expressions.Lockable.Tests.All_Tests (Report); Report.End_Section;