U315-010 Add shell command to ALS tester driver

Use this comman to create symbolic link during test run.
Fix regexp for `${NAME}` macro in tests. Add `DIR`
into environment variables.

Author: reznikmm

Makefile

@@ -130,12 +130,7 @@ vscode-test:
 	# This contains no useful test, so deactivated for now.
 	# cd integration/vscode/ada; npm run compile && node out/runTests.js
 
-prepare:
-	#  Create a symbol link required by a test
-	[ -e testsuite/ada_lsp/project_symlinks/link ] || \
-	  (cd testsuite/ada_lsp/project_symlinks; ln -s prj link)
-
-check: all prepare
+check: all
 	set -e; \
         if [ `$(PYTHON) -c "import sys;print('e3' in sys.modules)"` = "True" ]; then\
            (cd testsuite ; sh run.sh ) ; \

source/tester/tester-macros.adb

@@ -38,7 +38,7 @@ package body Tester.Macros is
    --  Turn Path into URI with scheme 'file://'
 
    Pattern : constant GNAT.Regpat.Pattern_Matcher :=
-     GNAT.Regpat.Compile ("\${([\W]+)}|\$URI{([^}]*)}");
+     GNAT.Regpat.Compile ("\${([\w]+)}|\$URI{([^}]*)}");
 
    Replace_Slash : constant Ada.Strings.Maps.Character_Mapping :=
      Ada.Strings.Maps.To_Mapping
@@ -176,8 +176,10 @@ package body Tester.Macros is
       Full_Name : constant String := Ada.Directories.Full_Name (Path);
       Directory : constant String :=
         Ada.Directories.Containing_Directory (Full_Name);
+      Env_With_Dir : Spawn.Environments.Process_Environment := Env;
    begin
-      Test := Expand (Test, Env, Directory);
+      Env_With_Dir.Insert ("DIR", Directory);
+      Test := Expand (Test, Env_With_Dir, Directory);
    end Expand;
 
    ----------------

source/tester/tester-macros.ads

@@ -25,7 +25,7 @@ package Tester.Macros is
      (Test : in out GNATCOLL.JSON.JSON_Value;
       Env  : Spawn.Environments.Process_Environment;
       Path : String);
-   --  Expand macros in given JSON test
+   --  Expand macros in given JSON test. The Path is test's path.
    --
    --  Currently only one macro is supported:
    --  * ${NAME} - expands with environment variable NAME from Env

source/tester/tester-tests.adb

@@ -31,7 +31,7 @@ package body Tester.Tests is
    Max_Wait : constant := 4_000;
    --  Max number of milliseconds to wait on a given snippet
 
-   type Command_Kind is (Start, Stop, Send, Comment);
+   type Command_Kind is (Start, Stop, Send, Shell, Comment);
 
    procedure Do_Start
      (Self    : in out Test'Class);
@@ -44,6 +44,10 @@ package body Tester.Tests is
      (Self    : in out Test'Class;
       Command : GNATCOLL.JSON.JSON_Value);
 
+   procedure Do_Shell
+     (Self    : in out Test'Class;
+      Command : GNATCOLL.JSON.JSON_Value);
+
    function Wait_Factor return Integer;
    --  Return the factor to multiply the delays with - useful for valgrind
    --  runs. This is an integer read from the environment variable
@@ -155,6 +159,96 @@ package body Tester.Tests is
       end loop;
    end Do_Send;
 
+   procedure Do_Shell
+     (Self    : in out Test'Class;
+      Command : GNATCOLL.JSON.JSON_Value)
+   is
+      pragma Unreferenced (Self);
+
+      function To_Program (Name : String) return String;
+      --  Take base name of the command and find it on PATH
+
+      function To_Program (Name : String) return String is
+         Found : GNAT.OS_Lib.String_Access :=
+           GNAT.OS_Lib.Locate_Exec_On_Path (Name);
+      begin
+         return Result : constant String := Found.all do
+            Free (Found);
+         end return;
+      end To_Program;
+
+      List  : constant GNATCOLL.JSON.JSON_Array := Command.Get;
+      Cmd   : constant String := To_Program (GNATCOLL.JSON.Get (List, 1).Get);
+      Args  : Spawn.String_Vectors.UTF_8_String_Vector;
+
+      type Shell_Listener is new Spawn.Processes.Process_Listener with record
+         Done : Boolean := False;
+      end record;
+
+      overriding procedure Finished
+        (Self      : in out Shell_Listener;
+         Exit_Code : Integer);
+
+      overriding procedure Error_Occurred
+        (Self          : in out Shell_Listener;
+         Process_Error : Integer);
+
+      overriding procedure Error_Occurred
+        (Self          : in out Shell_Listener;
+         Process_Error : Integer) is
+      begin
+         Ada.Text_IO.Put ("Fail to run '");
+         Ada.Text_IO.Put (Cmd);
+
+         for X of Args loop
+            Ada.Text_IO.Put (" ");
+            Ada.Text_IO.Put (X);
+         end loop;
+
+         Ada.Text_IO.Put ("' error ");
+         Ada.Text_IO.Put_Line (Process_Error'Image);
+         Self.Done := True;
+      end Error_Occurred;
+
+      overriding procedure Finished
+        (Self      : in out Shell_Listener;
+         Exit_Code : Integer) is
+      begin
+         if Exit_Code /= 0 then
+            Ada.Text_IO.Put ("Process '");
+            Ada.Text_IO.Put (Cmd);
+
+            for X of Args loop
+               Ada.Text_IO.Put (" ");
+               Ada.Text_IO.Put (X);
+            end loop;
+
+            Ada.Text_IO.Put ("' finished with code ");
+            Ada.Text_IO.Put_Line (Exit_Code'Image);
+         end if;
+
+         Self.Done := True;
+      end Finished;
+
+      Shell : Spawn.Processes.Process;
+
+      Listener : aliased Shell_Listener;
+   begin
+      for J in 2 .. GNATCOLL.JSON.Length (List) loop
+         Args.Append (GNATCOLL.JSON.Get (List, J).Get);
+      end loop;
+
+      Shell.Set_Listener (Listener'Unchecked_Access);
+      Shell.Set_Program (Cmd);
+      Shell.Set_Arguments (Args);
+      Shell.Start;
+
+      loop
+         Spawn.Processes.Monitor_Loop (Timeout => 10);
+         exit when Listener.Done;
+      end loop;
+   end Do_Shell;
+
    --------------
    -- Do_Start --
    --------------
@@ -591,6 +685,8 @@ package body Tester.Tests is
                Self.Do_Stop (Value);
             when Send =>
                Self.Do_Send (Value);
+            when Shell =>
+               Self.Do_Shell (Value);
             when Comment =>
                null;  --  Do nothing on comments
          end case;

testsuite/ada_lsp/README.md

@@ -90,9 +90,15 @@ should be in server response, but some values have a special meaning:
  * array `['<HAS>', item1, item2, ...]` - ensures that all given items are
    included into the array, any other array items are considered irrelevant and ignored
 
+### Command `shell`
+
+Property value - array of strings.
+
+Tester launches a shell command taking command and arguments from the array.
+
 ### Command `comment`
 
-Property value - array of string or just string.
+Property value - array of strings or just string.
 
 Tester just ignores this command. We use it to add test desription and other
 comments to JSON test script.
@@ -104,7 +110,7 @@ JSON file preprocessing
 
 Before execution Tester does some text substitution in each string literal.
  * Each substring `${NAME}` is replaced by an environment variable with
-given NAME.
+given NAME. The `DIR` environment variable points to test's directory.
 
  * Each substring `$URI{x}` is replaced by corresponding URI `file:///test_dir/x`.
 where `x` should be path relative to the directory where `.json` file is located.

testsuite/ada_lsp/project_symlinks/test.json

@@ -5,6 +5,8 @@
             "In this mode ALS shouldn't resolve symlink:",
             "the 'link/aaa.ads' file shouldn't be referred as 'prj/aaa.ads'"
         ]
+    },  {
+        "shell": ["sh", "-c", "rm -rf ${DIR}/link; ln -s prj ${DIR}/link" ]
     },  {
         "start": {
             "cmd": ["${ALS}"]