Add a test case for custom preprocessor

.github/workflows/build.yml

@@ -63,6 +63,11 @@ jobs:
       - run: opam exec -- make distclean
       - run: opam exec -- opam pin add -n ocamlbuild .
       - run: opam exec -- opam install -v ocamlbuild
+      - run: opam exec -- opam install -v menhir
+      - run: opam exec -- opam install -v camlp4
+        if: (! startsWith(matrix.ocaml-compiler, '5.2'))
+      - run: opam exec -- make test-external
+        if: (! startsWith(matrix.ocaml-compiler, '5.2'))
       - run: opam exec -- opam install -v mtime.1.0.0 # this tests topkg, with stub libraries
       - run: opam exec -- opam install -v inotify.2.3 # this tests oasis, with stub libraries
         if: (! startsWith(matrix.ocaml-compiler, '5')) && runner.os != 'Windows'

src/command.ml

@@ -129,7 +129,7 @@ let search_in_path cmd =
 
 (*** string_of_command_spec{,_with_calls *)
 let string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec =
-  let rec aux spec =
+  let rec aux encode spec =
     let b = Buffer.create 256 in
     let first = ref true in
     let put_space () =
@@ -139,7 +139,18 @@ let string_of_command_spec_with_calls call_with_tags call_with_target resolve_vi
         Buffer.add_char b ' '
     in
     let put_filename p =
-      Buffer.add_string b (Shell.quote_filename_if_needed p)
+      Buffer.add_string b (encode p)
+    in
+    let quote_filename_for_cmd_if_needed x =
+      (* external commands are unfortunately called with cmd.exe (via Sys.command).
+         Cmd.exe has strange quoting rules. The most notorious quirk is, that
+         you can't use forward slashes as path separators at the first position,
+         unless you quote the expression explicitly.
+         cmd.exe will interpret the slash and everything thereafter as first
+         parameter. Eg. 'bin/foo -x' is treated like 'bin /foo -x'. *)
+      if Shell.is_simple_filename x && not (String.contains x '/')
+      then x
+      else My_std.quote_cmd ("\"" ^ x ^ "\"")
     in
     let rec do_spec = function
       | N -> ()
@@ -148,15 +159,23 @@ let string_of_command_spec_with_calls call_with_tags call_with_target resolve_vi
       | P p -> put_space (); put_filename p
       | Px u -> put_space (); put_filename u; call_with_target u
       | V v -> if resolve_virtuals then do_spec (virtual_solver v)
-               else (put_space (); Printf.bprintf b "<virtual %s>" (Shell.quote_filename_if_needed v))
+               else (put_space (); Printf.bprintf b "<virtual %s>" (encode v))
       | S l -> List.iter do_spec l
       | T tags -> call_with_tags tags; do_spec (!tag_handler tags)
-      | Quote s -> put_space (); put_filename (aux s)
+      | Quote q ->
+        let c =
+          if Sys.win32 then
+            aux quote_filename_for_cmd_if_needed q
+          else
+            aux Shell.quote_filename_if_needed q
+        in
+        put_space ();
+        Buffer.add_string b (encode c)
     in
     do_spec spec;
     Buffer.contents b
   in
-  aux spec
+  aux (fun x -> Shell.quote_filename_if_needed x) spec
 
 let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore false x
 

src/my_std.ml

@@ -373,6 +373,19 @@ let sys_command cmd =
   if cmd = "" then 0 else
   sys_command cmd
 
+(* See https://learn.microsoft.com/en-us/archive/blogs/twistylittlepassagesallalike/everyone-quotes-command-line-arguments-the-wrong-way *)
+let quote_cmd s =
+  let b = Buffer.create (String.length s + 20) in
+  String.iter
+    (fun c ->
+       match c with
+       | '(' | ')' | '!' | '^' | '%' | '\"' | '<' | '>' | '&' | '|' ->
+         Buffer.add_char b '^'; Buffer.add_char b c
+       | _ ->
+         Buffer.add_char b c)
+    s;
+  Buffer.contents b
+
 (* FIXME warning fix and use Filename.concat *)
 let filename_concat x y =
   if x = Filename.current_dir_name || x = "" then y else

src/my_std.mli

@@ -74,6 +74,9 @@ val prepare_command_for_windows : string -> string array
 
 val env_path : string list Lazy.t
 
+val quote_cmd : string -> string
+
 (*/*)
+
 type log = { mutable dprintf : 'a. int -> ('a, Format.formatter, unit) format -> 'a }
 val log : log

src/signatures.mli

@@ -195,9 +195,9 @@ module type COMMAND = sig
                          instance). *)
     | V of string    (** A virtual command, that will be resolved at
                          execution using [resolve_virtuals] *)
-    | Quote of spec  (** A string that should be quoted like a
-                           filename but isn't really one. *)
-
+    | Quote of spec  (** Used for commands or part of commands,
+                        meant to be passed to [Sys.command] at some
+                        point. *)
   (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ]
     and vspec =
     [ `N

testsuite/external.ml

@@ -34,9 +34,7 @@ let () = test "Camlp4NativePlugin"
 let () = test "SubtoolOptions"
   ~description:"Options that come from tags that needs to be spliced \
                 to the subtool invocation (PR#5763)"
-  (* testing for the 'menhir' executable directly
-     is too hard to do in a portable way; test the ocamlfind package instead *)
-  ~requirements:(req_and (package_exists "menhirLib") (package_exists "camlp4"))
+  ~requirements:(req_and (package_exists "menhir") (package_exists "camlp4"))
   ~options:[`use_ocamlfind; `use_menhir; `tags ["package(camlp4.fulllib)"]]
   ~tree:[T.f "parser.mly"
             ~content:{|

testsuite/external_test_header.ml

@@ -2,7 +2,10 @@
    Findlib was loaded in findlibonly_test_header.ml *)
 let package_exists package =
   let open Findlib in
-  try ignore (package_directory package); Fullfilled
+  try
+    let dir = package_directory package in
+    Printf.eprintf "%s found in %s\n%!" package dir;
+    Fullfilled
   with No_such_package _ ->
     Missing (Printf.sprintf "the ocamlfind package %s" package)
 

testsuite/internal.ml

@@ -1,5 +1,62 @@
 #use "internal_test_header.ml";;
 
+
+let () = test "Preprocess"
+    ~description:"Check that preprocessor works"
+    ~requirements:ocamlopt_available
+    ~options:[]
+    ~tree:[
+      T.f "main.ml" ~content:{|let () = Printf.printf "line %d\n" __LINE__|};
+      T.f "preprocessor.ml" ~content:{|
+let () =
+  let all = Array.to_list Sys.argv |> List.tl in
+  let input = Sys.argv.(3) in
+  let txt = Sys.argv.(1) in
+  let shift = int_of_string (Sys.argv.(2)) in
+  let ic = open_in input in
+  for i = 1 to shift do
+    print_endline (Printf.sprintf "(* shift lines by one, %s *)" txt);
+  done;
+  (try
+  while true do
+    let l = input_line ic in
+    print_endline l;
+  done;
+  with End_of_file -> ());
+  print_endline {txt|let () = if __LINE__ <> 4 then failwith "unexpected shift" |txt};
+  print_endline (Printf.sprintf {txt|
+let () =
+  match [%s] with
+  | ["with space"; "2"; _file] -> ()
+  | l -> failwith (Printf.sprintf "Preprocessor received unexpected args: %%s" (String.concat " - " l))
+|txt} (String.concat "; " (List.map (Printf.sprintf "%S") all)))
+
+|};
+      T.f "myocamlbuild.ml" ~content:{|
+open Ocamlbuild_plugin
+let () =
+  dispatch begin function
+  | After_rules ->
+    dep ["mypreprocessor"] ["preprocessor.exe"];
+    flag ["ocaml"; "pp"; "mypreprocessor"] (S [P "./preprocessor.exe";
+                                               A "with space";
+                                               A "2"]);
+    rule "native to exe"
+    ~prods:["%.exe"]
+    ~dep:"%.native"
+    (fun env _build ->
+      let nat = env "%.native" and exe = env "%.exe" in
+      Cmd(S[A "cp"; A nat; A exe]))
+  | _ -> ()
+  end
+|};
+      T.f "_tags" ~content:{|
+<main.ml>: mypreprocessor
+|}]
+    ~targets:("main.native", [])
+    ~post_cmd:("./main.native")
+    ();;
+
 let () = test "BasicNativeTree"
   ~options:[`no_ocamlfind]
   ~description:"Output tree for native compilation"

testsuite/ocamlbuild_test.ml

@@ -40,6 +40,12 @@ let execute cmd =
     let ret_code = Unix.close_process_in ic
     in ret_code, List.rev !lst
 
+(* Simplified implementation of My_std.sys_command to avoid duplicating code. *)
+let sys_command cmd =
+  if Sys.win32
+  then Sys.command (Printf.sprintf "bash --norc --noprofile -c %S" cmd)
+  else Sys.command cmd
+
 let rm f =
   if exists f then
     ignore(Sys.command (Printf.sprintf "rm -r %s" f))
@@ -394,6 +400,7 @@ type test = { name     : string
             ; options  : Option.t list
             ; targets  : string * string list
             ; pre_cmd  : string option
+            ; post_cmd : string option
             ; failing_msg : string option
             ; run      : run list }
 
@@ -402,7 +409,7 @@ let tests = ref []
 let test name
     ~description
     ?requirements
-    ?(options=[]) ?(run=[]) ?pre_cmd ?failing_msg
+    ?(options=[]) ?(run=[]) ?pre_cmd ?post_cmd ?failing_msg
     ?(tree=[])
     ?(matching=[])
     ~targets ()
@@ -416,6 +423,7 @@ let test name
     options;
     targets;
     pre_cmd;
+    post_cmd;
     failing_msg;
     run;
   }]
@@ -508,6 +516,7 @@ let run ~root =
       ; targets
       ; failing_msg
       ; pre_cmd
+      ; post_cmd
       ; run } =
 
     let full_name = root ^ "/" ^ name in
@@ -525,15 +534,19 @@ let run ~root =
 
         (match pre_cmd with
           | None -> ()
-          | Some str -> ignore(Sys.command str));
+          | Some str -> ignore(sys_command str));
 
         let log_name = full_name ^ ".log" in
 
         let cmd = command options (fst targets :: snd targets) in
         let allow_failure = failing_msg <> None in
 
         let open Unix in
-
+        let post_cmd () =
+          match post_cmd with
+          | None -> true
+          | Some str -> sys_command str = 0
+        in
         match execute cmd with
           | WEXITED n,lines
           | WSIGNALED n,lines
@@ -562,8 +575,13 @@ let run ~root =
                   (* filter out -classic-display output *)
                   List.filter (fun s -> not (starts_with_plus s)) lines in
                 let msg = String.concat "\n" lines in
-                if failing_msg = msg then
-                  print_colored `Green "PASSED" name `Cyan description
+                if failing_msg = msg  then
+                  if post_cmd ()
+                  then print_colored `Green "PASSED" name `Cyan description
+                  else begin
+                    print_colored `Red "FAILED" name `Yellow "post command failed";
+                    failed := true
+                  end
                 else begin
                   print_colored `Red "FAILED" name `Yellow
                     ((Printf.sprintf "Failure with not matching message:\n\
@@ -576,7 +594,13 @@ let run ~root =
               List.concat
                 (List.map (Match.match_with_fs ~root:full_name) matching) in
             begin if errors == [] then
-                print_colored `Green "PASSED" name `Cyan description
+                if post_cmd ()
+                then
+                  print_colored `Green "PASSED" name `Cyan description
+                else begin
+                    print_colored `Red "FAILED" name `Yellow "post command failed";
+                    failed := true
+                  end
               else begin
                 if verbose then begin
                   print_colored `Red "FAILED" name `Yellow