From e8f53c930e3a80b3d2a1db590223db2dd2df1849 Mon Sep 17 00:00:00 2001
From: Patrick Baudin <patrick.baudin@cea.fr>
Date: Mon, 1 Feb 2021 09:55:00 +0100
Subject: [PATCH] [Ptests] use a wrapper to run frama-c tests
---
Makefile | 19 ++-
ptests/Makefile | 6 +-
ptests/dune | 9 ++
ptests/dune-project | 8 +-
ptests/ptests.ml | 337 +++++++++++++++++++++++++++++++++-----------
ptests/wtests.ml | 278 ++++++++++++++++++++++++++++++++++++
6 files changed, 571 insertions(+), 86 deletions(-)
create mode 100644 ptests/wtests.ml
diff --git a/Makefile b/Makefile
index 04605913217..d85b462f448 100644
--- a/Makefile
+++ b/Makefile
@@ -173,18 +173,27 @@ TEST_DIRS=tests $(wildcard src/plugins/*/tests)
tests.info:
echo "TEST_DIRS=$(TEST_DIRS)"
-# Note: the plublic name of ptest.exe is frama-c-ptest
+# Note: the public name of ptest.exe is frama-c-ptests
ptests/ptests.exe: ptests/ptests.ml
dune build --root ptests ptests.exe
+# Note: the public name of wtest.exe is frama-c-wtests
+ptests/wtests.exe: ptests/wtests.ml
+ dune build --root ptests wtests.exe
+
# Command for executing ptest (in order to generate dune test files)
-PTESTS=dune exec --root ptests -- ./ptests.exe
-PTESTS=dune exec --root ptests -- ./ptests.exe -v
+PTESTS=dune exec --root ptests -- frama-c-ptests
+#PTESTS=dune exec --root ptests -- frama-c-ptests -v
+WTESTS=dune exec --root ptests -- frama-c-wtests
.PHONY: ptests-help
-ptests-help: ptests/ptests.exe
+ptests-help:
$(PTESTS) --help
+.PHONY: wtests-help
+wtests-help:
+ $(WTESTS) --help
+
# Removes all dune files generated for testing
.PHONY: purge-tests
purge-tests:
@@ -197,7 +206,7 @@ clean-tests: purge-tests
# Generates all dune files used for testing
.PHONY: run-ptests
-run-ptests: config.sed purge-tests ptests/ptests.exe
+run-ptests: config.sed purge-tests
$(PTESTS) $(TEST_DIRS)
# run tests of for all configurations (requires all dune files)
diff --git a/ptests/Makefile b/ptests/Makefile
index b280e55b8a5..17b6e3c551c 100644
--- a/ptests/Makefile
+++ b/ptests/Makefile
@@ -21,12 +21,16 @@
##########################################################################
.PHONY: all
-all: ptests.exe
+all: ptests.exe wtests.exe
.PHONY: ptests.exe
ptests.exe:
dune build --root . ptests.exe
+.PHONY: wtests.exe
+wtests.exe:
+ dune build --root . wtests.exe
+
.PHONY: clean
clean: purge-tests
dune clean --root .
diff --git a/ptests/dune b/ptests/dune
index 5c078a03352..472d16d9395 100644
--- a/ptests/dune
+++ b/ptests/dune
@@ -3,4 +3,13 @@
(name ptests)
(modules ptests)
(libraries unix str)
+ (preprocess (pps ppx_deriving_yojson))
+)
+
+(executable
+ (public_name frama-c-wtests)
+ (name wtests)
+ (modules wtests)
+ (libraries unix str)
+ (preprocess (pps ppx_deriving_yojson))
)
diff --git a/ptests/dune-project b/ptests/dune-project
index 9fb467f1774..cd4156c86d4 100644
--- a/ptests/dune-project
+++ b/ptests/dune-project
@@ -1,2 +1,8 @@
(lang dune 2.7)
-(package (name frama-c-ptests))
+(allow_approximate_merlin)
+(package
+ (name frama-c-ptests)
+ (depends
+ (ppx_deriving_yojson (>= 3.5.1))
+ )
+)
diff --git a/ptests/ptests.ml b/ptests/ptests.ml
index cc4faa69cc8..26f3f6c5c7e 100644
--- a/ptests/ptests.ml
+++ b/ptests/ptests.ml
@@ -27,6 +27,9 @@ let nb_dune_files = ref 0
let nb_ignores = ref 0
let ignored_suites = ref []
+(* Set to an empty string to use no wrapper *)
+let wrapper_cmd = ref "frama-c-wtests -brief"
+
type env_t = {
config: string
; dir: string
@@ -187,6 +190,9 @@ let example_msg =
@@<alias-name> # Tests all configurations related to the <alias-name>@ \
@@<alias-name>_config # Tests only the default configuration.@ \
@@<alias-name>_config_<configuration> # Tests only the specified <configuration>.@ \
+ @@<PTEST_NAME>.wtests # Tests the specified file.@ \
+ @@<PTEST_NAME>.<PTEST_NUMBER>.exec.wtests # Tests the specified sub-test comand.@ \
+ @@<PTEST_NAME>.<PTEST_NUMBER>.execnow.wtests # Tests the specified execnow command.@ \
@@<PTEST_FILE> # Force to reproduce the corresponding test and prints the outputs.@ \
@@<PTEST_NAME>.<PTEST_NUMBER>.exec.show # Prints the related sub-test command.@ \
@@<PTEST_NAME>.<PTEST_NUMBER>.execnow.show # Prints the related execnow command.@ \
@@ -206,7 +212,7 @@ let example_msg =
test_file_regexp
!default_toplevel
-let umsg = "Usage: ptests [options] [names of test suites]"
+let umsg = "Usage: frama-c-ptests [options] [names of test suites]"
let default_dune_alias = ref "ptests"
let rec argspec =
@@ -214,6 +220,9 @@ let rec argspec =
("-v", Arg.Unit (fun () -> incr verbosity),
"Increase verbosity (up to twice)") ;
+ ("-wrapper" , Arg.String (fun s -> wrapper_cmd := s),
+ " <command> Uses a wrapper to executes tests (defaults to "^ !wrapper_cmd ^")");
+
("-adds-default-options" , Arg.String (fun s -> macro_default_options := !macro_default_options ^ " " ^ s),
" <options> Appends the <options> to the default value of the @DEFAULT_OPTIONS@ macro");
@@ -289,7 +298,7 @@ end = struct
exit 2)
| "IGNORE" -> incr nb_ignores;
ignored_suites := (ptests_config ^ ":" ^ value)::!ignored_suites;
- Format.eprintf "%s: %s=%s@." ptests_config key value
+ if !verbosity >=2 then Format.eprintf "%s: %s=%s@." ptests_config key value
| _ -> Format.eprintf "%s: setenv (DEPRECATED): %s=%s@." ptests_config key value;
in
if Sys.file_exists ptests_config then begin
@@ -451,10 +460,6 @@ type execnow =
ex_dir: SubDir.t; (** directory of test suite *)
ex_timeout: string;
- (* DEPRECATED FEATURE *)
- ex_once: bool; (** true iff the command has to be executed only once
- per config file (otherwise it is executed for
- every file of the test suite) *)
}
@@ -553,8 +558,8 @@ end = struct
let scan_execnow ~file ~once dir ex_timeout (s:string) =
if once=false then
- Format.eprintf "%a: using EXEC directive (DEPRECATED): %s@."
- (SubDir.pp_file ~dir) file s;
+ Format.eprintf "%s: using EXEC directive (DEPRECATED): %s@."
+ file s;
let rec aux (s:execnow) =
try
Scanf.sscanf s.ex_cmd "%_[ ]LOG%_[ ]%[-A-Za-z0-9_',+=:.\\@@]%_[ ]%s@\n"
@@ -570,8 +575,8 @@ end = struct
Scanf.sscanf s.ex_cmd "%_[ ]make%_[ ]%s@\n"
(fun cmd ->
(* It should be better to use a specific macro into the command (such as @MAKE@) for that. *)
- Format.eprintf "%a: EXEC%s directive with a make command (DEPRECATED): %s@."
- (SubDir.pp_file ~dir) file (if once then "NOW" else "") cmd;
+ Format.eprintf "%s: EXEC%s directive with a make command (DEPRECATED): %s@."
+ file (if once then "NOW" else "") cmd;
let s = aux ({ s with ex_cmd = cmd; }) in
{ s with ex_cmd = "make "^cmd; } )
with Scanf.Scan_failure _ ->
@@ -582,13 +587,12 @@ end = struct
ex_log = [];
ex_bin = [];
ex_dir = dir;
- ex_once = once;
ex_timeout;
}
in
if execnow.ex_log = [] && execnow.ex_bin = [] then
- Format.eprintf "%a: EXEC%s without LOG nor BIN target (DEPRECATED): %s@."
- (SubDir.pp_file ~dir) file (if once then "NOW" else "") s;
+ Format.eprintf "%s: EXEC%s without LOG nor BIN target (DEPRECATED): %s@."
+ file (if once then "NOW" else "") s;
execnow
let make_custom_opts =
@@ -994,18 +998,59 @@ end
let show_cmd =
let regexp = Str.regexp "%{[a-z]+:\\([^}]+\\)}" in
let subst = Str.global_replace regexp "\\1" in
- fun ?reslog ?errlog cmd ->
+ subst
+
+let redirection ?reslog ?errlog cmd =
match reslog, errlog with
- | None, None -> Format.sprintf "echo '%s'" (subst cmd)
- | None, Some err -> Format.sprintf "echo '%s 2> %s'" (subst cmd) err
- | Some res, None -> Format.sprintf "echo '%s > %s'" (subst cmd) res
- | Some res, Some err -> Format.sprintf "echo '%s > %s 2> %s'" (subst cmd) res err
+ | None, None -> cmd
+ | None, Some err -> Format.sprintf "%s 2> %s" cmd err
+ | Some res, None -> Format.sprintf "%s > %s" cmd res
+ | Some res, Some err -> Format.sprintf "%s > %s 2> %s" cmd res err
let ptests_alias ~env = config_name ~env (env.dune_alias ^ "_config")
let filter_log_regexp = Str.regexp "@PTEST_LOG@"
let mk_alias cmd suffix = Format.sprintf "%s.%d.%s" cmd.test_name cmd.nth suffix
+
+type wtest = {
+ dir: (string [@default ""]); (* information on the test directory *)
+ info: (string [@default ""]); (* information *)
+ cmd: (string [@default "echo unknown command"]);
+ ret_code: (int [@default 0]);
+ out: (string [@default "" (* bin target built by the command *) ]); (* sdtout target *)
+ err: (string [@default "" (* bin target built by the command *) ]); (* stderr target *)
+ tmpout: (string [@default ""]); (* temporary file to filter stdout result *)
+ tmperr: (string [@default ""]); (* temporary file to filter stderr result *)
+ sedout: (string [@default ""]); (* filter command for the stdout result *)
+ sederr: (string [@default ""]); (* filter command for the stderr result *)
+ bin: (string list [@default []]); (* binary targets (without oracles) *)
+ log: (string list [@default []]); (* log targets (compared to log oracles *)
+ oracle_dir: (string [@default "../oracle"]); (* directory containing the oracle of the log files *)
+ oracle_out: (string [@default "" ]); (* oracle of the stdout target *)
+ oracle_err: (string [@default "" ]); (* oracle of the stderr target *)
+}
+[@@deriving yojson]
+
+let std = false
+let pp_wtest ?(compacted=false) fmt wtest =
+ let writer = (if compacted
+ then (fun json -> Format.fprintf fmt "%s" (Yojson.Safe.to_string ~std json))
+ else (fun json -> Format.fprintf fmt "%a" (Yojson.Safe.pretty_print ~std) json))
+ in writer (wtest_to_yojson wtest)
+
+let default_wtest = match wtest_of_yojson (Yojson.Safe.from_string "{}") with
+ | Ok r -> r
+ | _ -> assert false
+
+let print_json_wrapper ~file wtest =
+ (* Prints the JSON file for the wrapper *)
+ if !verbosity >= 2 then Format.printf "%% Generates %S wrapper file...@." file;
+ let wrapper_cout = open_out file in
+ let wrapper_fmt = Format.formatter_of_out_channel wrapper_cout in
+ Format.fprintf wrapper_fmt "%a@" (pp_wtest ~compacted:false) wtest;
+ close_out wrapper_cout
+
let command_string ~env ~result_fmt ~oracle_fmt command =
let log_prefix = log_prefix ~env command in
let reslog = log_prefix ^ ".res.log" in
@@ -1017,42 +1062,128 @@ let command_string ~env ~result_fmt ~oracle_fmt command =
let deps = command.deps in
let accepted_exit_code = Format.sprintf "with-accepted-exit-codes %d" command.exit_code in
let command_string = basic_command_string command in
- Format.fprintf result_fmt
- "(rule ; TEST #%d OF TEST FILE %S\n \
- (targets %S %S %a)\n \
- (deps %a %S (package frama-c)%a)\n \
- (action (with-stderr-to %S (with-stdout-to %S (%s (system %S)))))\n\
- )@."
- command.nth command.file
- cmderrlog
- cmdreslog
- print_list command.log_files
- print_list deps
- command.file
- Fmt.(list (package_as_deps (quote plugin_as_package))) command.plugins
- cmderrlog
- cmdreslog
- accepted_exit_code
- command_string
- ;
- begin
+ let filter_res,filter_err,wtest =
match command.filter with
- | None -> ()
+ | None -> "","",default_wtest
| Some filter ->
let regexp = Str.regexp "@PTEST_ORACLE@" in
- let filter_rule txt fin fout foracle =
+ let filter_cmd fin foracle =
let filter = Str.global_replace regexp foracle filter in
- Format.fprintf result_fmt
- "(rule ; FILTER %s #%d OF TEST FILE %S\n \
- (action (with-stdout-to %S (with-accepted-exit-codes (or 0 1 2 125) (system %S))))\n\
- )@."
- txt
- command.nth command.file
- fout (Format.sprintf "%s %%{dep:%s}" filter fin)
+ Format.sprintf "%s %s" filter fin
in
- filter_rule "RES" cmdreslog reslog (log_prefix ^ ".res.oracle") ;
- filter_rule "ERR" cmderrlog errlog (log_prefix ^ ".err.oracle")
- end ;
+ let filter_res = filter_cmd cmdreslog (log_prefix ^ ".res.oracle") in
+ let filter_err = filter_cmd cmderrlog (log_prefix ^ ".err.oracle") in
+ filter_res,filter_err, { default_wtest with
+ sedout = redirection ~reslog filter_res ;
+ sederr = redirection ~reslog:errlog filter_err ;
+ tmpout = cmdreslog ;
+ tmperr = cmderrlog ;
+ }
+ in
+ let oracle_prefix = oracle_prefix ~env command in
+ let wtest =
+ { wtest with
+ dir = SubDir.get (SubDir.result_subdir ~env command.directory) ;
+ info = Format.sprintf "TEST #%d OF TEST FILE %s/%s"
+ command.nth (SubDir.get command.directory) command.file;
+ cmd = redirection ~reslog:cmdreslog ~errlog:cmderrlog command_string ;
+ out = reslog;
+ err = errlog;
+ ret_code = command.exit_code;
+ log = command.log_files;
+ oracle_out = Filename.concat ".." (oracle_prefix ^ ".res.oracle");
+ oracle_err = Filename.concat ".." (oracle_prefix ^ ".err.oracle");
+ }
+ in
+ let wtest = if wtest.log = [] then wtest else
+ { wtest with
+ oracle_dir = SubDir.get (SubDir.oracle_subdir ~env SubDir.upper_dir)
+ }
+ in
+ let wrapper_basename = mk_alias command "exec.wtests" in
+ if !wrapper_cmd <> "" then begin
+ Format.fprintf result_fmt
+ "(rule ; %s\n \
+ (alias %S)\n \
+ (targets %S %S %a)\n \
+ (deps %S %S %a %a %S (package frama-c)%a)\n \
+ (action (run %s %%{dep:%s} %S %a))\n\
+ )@."
+ (* rules: *)
+ wtest.info
+ (* alias *)
+ wrapper_basename
+ (* targets: *)
+ cmderrlog
+ cmdreslog
+ print_list command.log_files
+ (* deps: *)
+ wtest.oracle_out
+ wtest.oracle_err
+ print_list (List.map (Filename.concat wtest.oracle_dir) command.log_files)
+ print_list deps
+ command.file
+ Fmt.(list (package_as_deps (quote plugin_as_package))) command.plugins
+ (* action: *)
+ !wrapper_cmd
+ wrapper_basename
+ wtest.cmd
+ print_list (if command.filter = None then [] else [wtest.sedout ; wtest.sederr]);
+
+ let wtest =
+ { wtest with
+ cmd = show_cmd wtest.cmd ;
+ sedout = show_cmd wtest.sedout ;
+ sederr = show_cmd wtest.sederr
+ }
+ in
+ (* Prints the JSON file for the wrapper *)
+ print_json_wrapper wtest
+ ~file:(SubDir.make_file (SubDir.result_subdir ~env command.directory) wrapper_basename);
+ end
+ else
+ Format.fprintf result_fmt
+ "(rule ; %s\n \
+ (alias %S)\n \
+ (targets %S %S %a)\n \
+ (deps %a %S (package frama-c)%a)\n \
+ (action (with-stderr-to %S (with-stdout-to %S (%s (system %S)))))\n\
+ )@."
+ (* rules: *)
+ wtest.info
+ (* alias *)
+ wrapper_basename
+ (* targets: *)
+ cmderrlog
+ cmdreslog
+ print_list command.log_files
+ (* deps: *)
+ print_list deps
+ command.file
+ Fmt.(list (package_as_deps (quote plugin_as_package))) command.plugins
+ (* action: *)
+ cmderrlog
+ cmdreslog
+ accepted_exit_code
+ command_string
+ ;
+ let filter_rule txt fin fout cmd =
+ if cmd <> "" then
+ Format.fprintf result_fmt
+ "(rule ; FILTER %s #%d OF TEST FILE %S\n \
+ (deps %S)
+ (action (with-stdout-to %S (with-accepted-exit-codes (or 0 1 2 125) (system %S))))\n\
+ )@."
+ txt
+ command.nth
+ command.file
+ (* deps *)
+ fin
+ (*action *)
+ fout cmd
+ in
+ filter_rule "RES" cmdreslog reslog filter_res ;
+ filter_rule "ERR" cmderrlog errlog filter_err ;
List.iteri (fun n log ->
Format.fprintf result_fmt
"(rule ; COMPARE TARGET #%d OF TEST #%d FOR TEST FILE %S\n \
@@ -1089,9 +1220,8 @@ let command_string ~env ~result_fmt ~oracle_fmt command =
print_list deps
command.file
Fmt.(list (package_as_deps (quote plugin_as_package))) command.plugins
- (show_cmd ~reslog ~errlog command_string);
+ ("echo '" ^ show_cmd wtest.cmd ^"'");
- let oracle_prefix = oracle_prefix ~env command in
let diff_alias = log_prefix ^ ".diff" in
(* diff with oracles *)
Format.fprintf result_fmt
@@ -1100,7 +1230,7 @@ let command_string ~env ~result_fmt ~oracle_fmt command =
(action (diff %S %S))\n\
)@."
diff_alias
- (Filename.concat ".." (oracle_prefix ^ ".res.oracle"))
+ wtest.oracle_out
reslog;
Format.fprintf result_fmt
"(rule\n \
@@ -1108,7 +1238,7 @@ let command_string ~env ~result_fmt ~oracle_fmt command =
(action (diff %S %S))\n\
)@."
diff_alias
- (Filename.concat ".." (oracle_prefix ^ ".err.oracle"))
+ wtest.oracle_err
errlog;
Format.fprintf result_fmt
"(alias (deps (alias %S)) (name %S); (enabled_if (and true %a))\n\
@@ -1178,28 +1308,69 @@ let dispatcher ~env ~result_fmt ~oracle_fmt file directory config =
load_module = config.dc_libs @ config.dc_load_module;
}
in
- let res =
- { execnow with
- ex_cmd = basic_command_string cmd;
- ex_log = List.map (Macros.expand cmd.macros) execnow.ex_log;
- ex_bin = List.map (Macros.expand cmd.macros) execnow.ex_bin;
- }
+ let wtest = {
+ default_wtest with
+ dir = SubDir.get (SubDir.result_subdir ~env cmd.directory) ;
+ info = Format.sprintf "EXECNOW #%d OF TEST FILE %s/%s"
+ nth (SubDir.get directory) file;
+ cmd = basic_command_string cmd;
+ log = List.map (Macros.expand cmd.macros) execnow.ex_log;
+ bin = List.map (Macros.expand cmd.macros) execnow.ex_bin;
+ }
in
- Format.fprintf result_fmt
- "(rule ; EXECNOW #%d OF TEST FILE %S\n \
- (alias %s)\n \
- (deps %a (package frama-c)%a)\n \
- (targets %a %a)\n \
- (action (system %S))\n\
- )@."
- nth file
- (ptests_alias ~env)
- print_list config.dc_deps
- Fmt.(list (package_as_deps (quote plugin_as_package))) config.dc_plugins
- print_list res.ex_log
- print_list res.ex_bin
- res.ex_cmd
- ;
+ let wrapper_basename = mk_alias cmd "execnow.wtests" in
+ if !wrapper_cmd <> "" then begin
+ Format.fprintf result_fmt
+ "(rule ; %s\n \
+ (alias %s)\n \
+ (deps %a (package frama-c)%a)\n \
+ (targets %a %a)\n \
+ (action (run %s %%{dep:%s} %S))\n\
+ )@."
+ (* rules: *)
+ wtest.info
+ (* alias *)
+ wrapper_basename
+ (* deps: *)
+ print_list config.dc_deps
+ Fmt.(list (package_as_deps (quote plugin_as_package))) config.dc_plugins
+ (* targets: *)
+ print_list wtest.log
+ print_list wtest.bin
+ (* action: *)
+ !wrapper_cmd
+ wrapper_basename
+ wtest.cmd;
+ let wtest =
+ { wtest with
+ cmd = show_cmd wtest.cmd ;
+ }
+ in
+ (* Prints the JSON file for the wrapper *)
+ print_json_wrapper wtest
+ ~file:(SubDir.make_file (SubDir.result_subdir ~env cmd.directory) wrapper_basename);
+ end
+ else begin
+ Format.fprintf result_fmt
+ "(rule ; %s\n \
+ (alias %s)\n \
+ (deps %a (package frama-c)%a)\n \
+ (targets %a %a)\n \
+ (action (system %S))\n\
+ )@."
+ (* rules: *)
+ wtest.info
+ (* alias *)
+ wrapper_basename
+ (* deps: *)
+ print_list config.dc_deps
+ Fmt.(list (package_as_deps (quote plugin_as_package))) config.dc_plugins
+ (* targets: *)
+ print_list wtest.log
+ print_list wtest.bin
+ (* action: *)
+ wtest.cmd
+ end;
Format.fprintf result_fmt
"(rule ; REPRODUCE EXECNOW #%d OF TEST FILE %S\n \
(alias %s)\n \
@@ -1210,7 +1381,7 @@ let dispatcher ~env ~result_fmt ~oracle_fmt file directory config =
(mk_alias cmd "execnow")
print_list config.dc_deps
Fmt.(list (package_as_deps (quote plugin_as_package))) config.dc_plugins
- res.ex_cmd
+ wtest.cmd
;
Format.fprintf result_fmt
"(rule ; SHOW EXECNOW COMMAND #%d OF TEST FILE %S\n \
@@ -1222,7 +1393,7 @@ let dispatcher ~env ~result_fmt ~oracle_fmt file directory config =
(mk_alias cmd "execnow.show")
print_list config.dc_deps
Fmt.(list (package_as_deps (quote plugin_as_package))) config.dc_plugins
- (show_cmd res.ex_cmd)
+ ("echo '" ^ show_cmd wtest.cmd ^"'");
;
List.iteri (fun n log ->
Format.fprintf result_fmt
@@ -1234,7 +1405,7 @@ let dispatcher ~env ~result_fmt ~oracle_fmt file directory config =
(ptests_alias ~env)
(SubDir.make_file (SubDir.oracle_subdir ~env SubDir.upper_dir) log)
log
- ) res.ex_log
+ ) wtest.log
in
List.iteri (fun n cmxs ->
let libraries = String.concat " " config.dc_libs in
@@ -1255,10 +1426,18 @@ let dispatcher ~env ~result_fmt ~oracle_fmt file directory config =
if config.dc_commands <> [] || config.dc_execnow <> [] then begin
let print_list_alias fmt l = List.iter (Format.fprintf fmt "(alias %S)") l in
Format.fprintf result_fmt
- "(alias (deps%a%a) (name %S))@."
+ "; TEST FILE %S\n\
+ (alias (deps %a%a) (name %S)) ; to performs all sub-tests related to a file\n \
+ (alias (deps %a%a) (name %S)) ; to reproduce and visualize the all sub-test outputs related to a file@."
+ file
+ (* alias #1 *)
+ print_list_alias (List.mapi (fun i _ -> Format.sprintf "%s.%d.exec.wtests" test_name i) config.dc_commands)
+ print_list_alias (List.mapi (fun i _ -> Format.sprintf "%s.%d.execnow.wtests" test_name i) config.dc_execnow)
+ (Format.sprintf "%s.wtests" test_name)
+ (* alias #2 *)
print_list_alias (List.mapi (fun i _ -> Format.sprintf "%s.%d.exec" test_name i) config.dc_commands)
print_list_alias (List.mapi (fun i _ -> Format.sprintf "%s.%d.execnow" test_name i) config.dc_execnow)
- file
+ file;
end ;
List.iter make_cmd config.dc_commands;
List.iter make_execnow_cmd config.dc_execnow;
diff --git a/ptests/wtests.ml b/ptests/wtests.ml
new file mode 100644
index 00000000000..e235d8901c0
--- /dev/null
+++ b/ptests/wtests.ml
@@ -0,0 +1,278 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2020 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+(** Command-line flags *)
+let verbosity = ref 1
+
+let cmp_cmd = "diff --new-file -q"
+let diff_cmd = "diff --new-file"
+
+(* ------------------------------- *)
+
+module Filename = struct
+ include Filename
+ let concat =
+ if Sys.os_type = "Win32" then
+ fun a b -> a ^ "/" ^ b
+ else
+ concat
+end
+
+(* ------------------------------- *)
+
+let pp_json fmt json =
+ Format.fprintf fmt "%% dune build @@%s" json
+
+let fail ~json s info =
+ Format.printf "%a: Error - %s@.%% Aborting: %s@." pp_json json s info ;
+ exit 2
+
+let output_unix_error (exn : exn) =
+ match exn with
+ | Unix.Unix_error (error, _function, arg) ->
+ let message = Unix.error_message error in
+ if arg = "" then
+ Format.eprintf "%s@." message
+ else
+ Format.eprintf "%s: %s@." arg message
+ | _ -> assert false
+
+let unlink ?(silent = true) file =
+ let open Unix in
+ try
+ Unix.unlink file
+ with
+ | Unix_error _ when silent -> ()
+ | Unix_error (ENOENT,_,_) -> () (* Ignore "No such file or directory" *)
+ | Unix_error _ as e -> output_unix_error e
+
+let system =
+ if Sys.os_type = "Win32" then
+ fun f ->
+ Unix.system (Format.sprintf "bash -c %S" f)
+ else
+ fun f ->
+ Unix.system f
+
+let print_file dir_info file =
+ Format.printf "%% Generated output file: %s/%s@." dir_info file;
+ try
+ let cin = open_in file in
+ try
+ while true do
+ let line = input_line cin in
+ Format.printf "%s\n" line
+ done
+ with _ ->
+ close_in cin
+ with _ ->
+ Format.printf "%% Cannot open file: %s@." file
+
+(* ------------------------------- *)
+
+let example_msg =
+ Format.sprintf
+ "@.@[<v 0>\
+ Wrapper to run test command.@."
+
+let umsg = "Usage: frama-c-wtests [options] <json-config> <test-command>*"
+
+let rec argspec =
+ [
+ ("-v", Arg.Unit (fun () -> incr verbosity),
+ "Increase verbosity (up to twice)") ;
+ ("-brief", Arg.Unit (fun () -> verbosity := 0),
+ "Brief report only on test failure") ;
+ ]
+and help_msg () = Arg.usage (Arg.align argspec) umsg
+
+let parse_args () =
+ let suites = ref [] in
+ let add_test_suite s = suites := s :: !suites in
+ Arg.parse
+ ((Arg.align
+ (List.sort
+ (fun (optname1, _, _) (optname2, _, _) ->
+ compare optname1 optname2
+ ) argspec)
+ ) @ ["", Arg.Unit (fun () -> ()), example_msg;])
+ add_test_suite
+ umsg;
+ List.rev !suites
+
+(* ------------------------------- *)
+
+let launch command_string =
+ let result = system command_string in
+ match result with
+ | Unix.WEXITED 127 ->
+ Format.printf "%% Couldn't execute command.:@\n%s@\nStopping@."
+ command_string ;
+ exit 1
+ | Unix.WEXITED r -> r
+ | Unix.WSIGNALED s ->
+ Format.printf
+ "%% SIGNAL %d received while executing command:@\n%s@\nStopping@."
+ s command_string ;
+ exit 1
+ | Unix.WSTOPPED s ->
+ Format.printf
+ "%% STOP %d received while executing command:@\n%s@\nStopping@."
+ s command_string;
+ exit 1
+
+let rm_filter_result (_cmd,stdfile) = unlink stdfile
+
+let filter (cmd,_stdfile) =
+ if !verbosity > 0 then Format.printf "%% Run filter command: %s@." cmd;
+ let ret_code = launch cmd in
+ if !verbosity > 0 && ret_code <> 0 then Format.printf "%% note: the filter command returned an error code (%d)@." ret_code
+
+let compare_files ~json ~error ~result oracle =
+ let not_generated = not (Sys.file_exists result) in
+ if not_generated then
+ Format.printf "%a: missing target %S@." pp_json json result;
+ let diff_cmd = if !verbosity > 0 then diff_cmd else cmp_cmd in
+ let cmd = Format.sprintf "%s %s %s" (if !verbosity > 0 then diff_cmd else cmp_cmd) oracle result in
+ if !verbosity > 0 then Format.printf "%% Run compare command: %s@." cmd;
+ let ret_code = launch cmd in
+ let is_ko = ret_code <> 0 in
+ if is_ko then Format.printf "%a: diff failure on diff: (cd _build/default && %s %S %S)@." pp_json json diff_cmd result oracle ;
+ error || is_ko
+
+let compare_std ~json error = function
+ | "" -> fun _ -> error
+ | result -> compare_files ~json ~error ~result
+
+let compare_log ~json oracle_dir error result =
+ compare_files ~json ~error ~result (Filename.concat oracle_dir result)
+
+let remove file = if file <> "" then unlink file
+
+let extract filters targets = function
+ | "" -> fun _ _ -> filters,targets
+ | stdfile -> function
+ | "" -> fun _ -> filters,(stdfile::targets)
+ | tmp -> fun cmd -> ((cmd,stdfile)::filters),(tmp::stdfile::targets)
+
+type wtest = {
+ info: (string [@default ""]); (* info *)
+ dir: (string [@default ""]); (* test directory *)
+ cmd: (string [@default "echo unknown command"]);
+ ret_code: (int [@default 0]);
+ out: (string [@default "" (* bin target built by the command *) ]); (* sdtout target *)
+ err: (string [@default "" (* bin target built by the command *) ]); (* stderr target *)
+ tmpout: (string [@default ""]); (* temporary file to filter stdout result *)
+ tmperr: (string [@default ""]); (* temporary file to filter stderr result *)
+ sedout: (string [@default ""]); (* filter command for the stdout result *)
+ sederr: (string [@default ""]); (* filter command for the stderr result *)
+ bin: (string list [@default []]); (* binary targets (without oracles) *)
+ log: (string list [@default []]); (* log targets (compared to log oracles *)
+ oracle_dir: (string [@default "../oracle"]); (* directory containing the oracle of the log files *)
+ oracle_out: (string [@default "" ]); (* oracle of the stdout target *)
+ oracle_err: (string [@default "" ]); (* oracle of the stderr target *)
+}
+[@@deriving of_yojson]
+
+let wrapper json test =
+ let sed,logs = extract [] test.log test.out test.tmpout test.sedout in
+ let sed,logs = extract sed logs test.err test.tmperr test.sederr in
+ if logs <> [] || test.bin <> [] then begin
+ if !verbosity > 0 then Format.printf "%% Clean targets...@.";
+ List.iter remove logs;
+ List.iter remove test.bin
+ end;
+ if !verbosity > 0 then Format.printf "%% Run test command: %s@." test.cmd;
+ let ret_code = launch test.cmd in
+ let error = ret_code <> test.ret_code in
+ if error || !verbosity > 0 then begin
+ if test.out <> "" then print_file test.dir (if test.tmpout = "" then test.out else test.tmpout) ;
+ if test.err <> "" then print_file test.dir (if test.tmperr = "" then test.err else test.tmperr)
+ end;
+ if error then begin
+ Format.printf "%a: return code (%d) differs from the requested code (%d) for the command:%s@."
+ pp_json json ret_code test.ret_code test.cmd;
+ true
+ end else begin
+ List.iter filter sed ;
+ let is_cmp_ko = compare_std ~json false test.out test.oracle_out in
+ let is_cmp_ko = compare_std ~json is_cmp_ko test.err test.oracle_err in
+ let is_cmp_ko = List.fold_left (compare_log ~json test.oracle_dir) is_cmp_ko test.log in
+ if !verbosity = 0 then
+ (* In `-brief` mode (used by the `dune` file generated by `frama-c-ptests`),
+ the filtered result file are removed
+ in order to let `dune` applying the filters. *)
+ List.iter rm_filter_result sed ;
+ (* In `-brief` mode,
+ the comparison failures are not reported with an error code
+ in order to let `dune` reporting them with the textual differences. *)
+ (if !verbosity > 1 then is_cmp_ko else false)
+ end
+
+let parse ~json =
+ if !verbosity > 0 then Format.printf "%% Parsing Jsonjson...@.";
+ match wtest_of_yojson (Yojson.Safe.from_file json) with
+ | Error txt -> fail ~json txt "Json file cannot be parsed"
+ | Ok r -> r
+
+let wrapper ~json =
+ try
+ let test = parse ~json in
+ let json = test.dir ^ "/" ^ json in
+ if !verbosity > 0 then
+ Format.printf "%% Wrapping info: %s@." test.info ;
+ match test with
+ | { info; out=""; tmpout=tmp; sedout=sed; _} when tmp <> "" || sed <> "" -> fail ~json "StdOut filter cannot be applied" info
+ | { info; err=""; tmperr=tmp; sederr=sed; _} when tmp <> "" || sed <> "" -> fail ~json "StdErr filter cannot be applied" info
+ | { info; out=std; oracle_out=oracle; _} when (std <> "") <> (oracle <> "") -> fail ~json "StdOut file cannot be compared to an oracle" info
+ | { info; err=std; oracle_err=oracle; _} when (std <> "") <> (oracle <> "") -> fail ~json "StdErr file cannot be compared to an oracle" info
+ | { info; tmpout=tmp; sedout=sed; _} when (tmp <> "") <> (sed <> "") -> fail ~json "StdOut filter cannot be applied" info
+ | { info; tmperr=tmp; sederr=sed; _} when (tmp <> "") <> (sed <> "") -> fail ~json "StdErr filter cannot be applied" info
+ | _ ->
+ if wrapper json test then
+ fail ~json "Test failed" test.info
+ with
+ | Yojson.Json_error txt
+ | Sys_error txt -> fail ~json txt "Json file cannot be parsed"
+
+
+let () =
+ let args = parse_args () in
+ (* verbosity := 1; *)
+ match args with
+ | json::commands ->
+ if !verbosity > 0 then begin
+ Format.printf "%% Wrapping from json file: %S@." json ;
+ match commands with
+ | cmd::filters ->
+ Format.printf "%% Wrapped command: %s@." cmd ;
+ List.iter (fun s -> Format.printf "%% Wrapped filter: %s@." s) filters;
+ | _ -> ()
+ end;
+ wrapper ~json
+ | _ -> help_msg () ; exit 1
+
+(*
+Local Variables:
+compile-command: "LC_ALL=C make -C .. ptests"
+End:
+*)
--
GitLab