ptests.ml 59.2 KB
Newer Older
1
2
3
4
(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
Andre Maroneze's avatar
Andre Maroneze committed
5
(*  Copyright (C) 2007-2020                                               *)
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
(*    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).            *)
(*                                                                        *)
(**************************************************************************)

(** the options to launch the toplevel with if the test file is not
     annotated with test options *)
let default_options = "-journal-disable -check"

let system =
  if Sys.os_type = "Win32" then
    fun f ->
      Unix.system (Format.sprintf "bash -c %S" f)
  else
    fun f ->
      Unix.system f
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
module Filename = struct
  include Filename
  let concat =
    if Sys.os_type = "Win32" then
      fun a b -> a ^ "/" ^ b
    else
      concat

  let cygpath r =
    let cmd =
      Format.sprintf
        "bash -c \"cygpath -m %s\""
        (String.escaped (String.escaped r))
    in
    let in_channel  = Unix.open_process_in cmd in
    let result = input_line in_channel in
    ignore(Unix.close_process_in in_channel);
    result

  let temp_file =
    if Sys.os_type = "Win32" then
      fun a b -> let r = temp_file a b in
        cygpath r
    else
      fun a b -> temp_file a b
60

61
  let sanitize f = String.escaped f
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
end

let string_del_suffix suffix s =
  let lsuffix = String.length suffix in
  let ls = String.length s in
  if ls >= lsuffix && String.sub s (ls - lsuffix) lsuffix = suffix then
    Some (String.sub s 0 (ls - lsuffix))
  else None

let str_mutex = Mutex.create()

let str_global_replace regex repl s =
  Mutex.lock str_mutex;
  let res = Str.global_replace regex repl s in
  Mutex.unlock str_mutex; res

let str_string_match regex s n =
  Mutex.lock str_mutex;
  let res = Str.string_match regex s n in
  Mutex.unlock str_mutex; res

83
84
85
86
87
88
89
90
91
92
93
94
95
(* If regex1 matches inside s, adds suffix to the first occurrence of regex2.
   If matched, returns (replaced string, true), otherwise returns (s, false).
*)
let str_string_match_and_replace regex1 regex2 ~suffix s =
  Mutex.lock str_mutex;
  let replaced_str, matched =
    if Str.string_match regex1 s 0 then
      Str.replace_first regex2 ("\\1" ^ suffix) s, true
    else s, false
  in
  Mutex.unlock str_mutex;
  (replaced_str, matched)

96
97
98
99
100
101
102
103
104
105
let str_split regex s =
  Mutex.lock str_mutex;
  let res = Str.split regex s in
  Mutex.unlock str_mutex; res

let default_env = ref []

let add_default_env x y = default_env:=(x,y)::!default_env

let add_env var value =
106
107
  add_default_env var value;
  Unix.putenv var value
108
109
110

let print_default_env fmt =
  match !default_env with
111
112
113
114
115
    [] -> ()
  | l ->
    Format.fprintf fmt "@[Env:@\n";
    List.iter (fun (x,y) -> Format.fprintf fmt "%s = \"%s\"@\n"  x y) l;
    Format.fprintf fmt "@]"
116
117
118
119

let default_env var value =
  try
    let v = Unix.getenv var in
120
    add_default_env (var ^ " (set from outside)") v
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
  with Not_found -> add_env var value

(** the name of the directory-wide configuration file*)
let dir_config_file = "test_config"

(** the files in [suites] whose name matches
    the pattern [test_file_regexp] will be considered as test files *)
let test_file_regexp = ".*\\.\\(c\\|i\\)$"

(** the pattern that ends the parsing of options in a test file *)
let end_comment = Str.regexp ".*\\*/"

let regex_cmxs = Str.regexp ("\\([^/]+\\)[.]cmxs\\($\\|[ \t]\\)")

let opt_to_byte toplevel =
  match string_del_suffix "frama-c" toplevel with
  | Some path -> path ^ "frama-c.byte"
  | None ->
    match string_del_suffix "toplevel.opt" toplevel with
    | Some path -> path ^ "toplevel.byte"
    | None ->
      match string_del_suffix "frama-c-gui" toplevel with
      | Some path -> path ^ "frama-c-gui.byte"
      | None ->
        match string_del_suffix "viewer.opt" toplevel with
        | Some path -> path ^ "viewer.byte"
        | None -> toplevel

let opt_to_byte_options options =
  str_global_replace regex_cmxs "\\1.cmo\\2" options

let execnow_opt_to_byte cmd =
  let cmd = opt_to_byte cmd in
  opt_to_byte_options cmd


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
163
    else
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
      Format.eprintf "%s: %s@." arg message
  | _ -> assert false

let mv src dest =
  try
    Unix.rename src dest
  with Unix.Unix_error _ as e ->
    output_unix_error e

let unlink ?(silent = true) file =
  let open Unix in
  try
    Unix.unlink file
  with
  | Unix_error _ when silent -> ()
179
  | Unix_error (ENOENT,_,_) -> () (* Ignore "No such file or directory" *)
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
  | Unix_error _ as e -> output_unix_error e

let is_file_empty_or_nonexisting filename =
  let open Unix in
  try
    (Unix.stat filename).st_size = 0
  with
  | Unix_error (UnixLabels.ENOENT, _, _) -> (* file does not exist *)
    true
  | Unix_error _ as e ->
    output_unix_error e;
    raise e

let base_path = Filename.current_dir_name
(*    (Filename.concat
        (Filename.dirname Sys.executable_name)
        Filename.parent_dir_name)
*)

(** Command-line flags *)

type behavior = Examine | Update | Run | Show | Gui
let behavior = ref Run
let verbosity = ref 0
let dry_run = ref false
let use_byte = ref false
let use_diff_as_cmp = ref (Sys.os_type = "Win32")
let do_diffs = ref (if Sys.os_type = "Win32" then "diff --strip-trailing-cr -u"
                    else "diff -u")
let do_cmp = ref (if Sys.os_type="Win32" then !do_diffs
                  else "cmp -s")
let do_make = ref "make"
let n = ref 4    (* the level of parallelism *)
let suites = ref []
(** options appended to toplevel for all tests *)
let additional_options = ref ""
(** options prepended to toplevel for all tests *)
let additional_options_pre = ref ""

(** special configuration, with associated oracles *)
let special_config = ref ""
let do_error_code = ref false

let exclude_suites = ref []

let exclude s = exclude_suites := s :: !exclude_suites

let xunit = ref false

let io_mutex = Mutex.create ()

let lock_fprintf f =
  Mutex.lock io_mutex;
  Format.kfprintf (fun _ -> Mutex.unlock io_mutex) f

let lock_printf s = lock_fprintf Format.std_formatter s
let lock_eprintf s = lock_fprintf Format.err_formatter s

let make_test_suite s =
  suites := s :: !suites

(* Those variables are read from a ptests_config file *)
let default_suites = ref []
let toplevel_path = ref ""

let change_toplevel_to_gui () =
  let s = !toplevel_path in
  match string_del_suffix "toplevel.opt" s with
  | Some s -> toplevel_path := s ^ "viewer.opt"
  | None ->
    match string_del_suffix "toplevel.byte" s with
    | Some s -> toplevel_path := s ^ "viewer.byte"
    | None ->
      match string_del_suffix "frama-c" s with
      | Some s -> toplevel_path := s ^ "frama-c-gui"
      | None ->
        match string_del_suffix "frama-c.byte" s with
        | Some s -> toplevel_path := s ^ "frama-c-gui.byte"
        | None -> ()


let () =
  Unix.putenv "LC_ALL" "C" (* some oracles, especially in Jessie, depend on the
                              locale *)
let example_msg =
  Format.sprintf
    "@.@[<v 0>\
267
268
269
270
     A test suite can be the name of a directory in ./tests or \
     the path to a file.@ @ \
     @[<v 1>\
     Some variables can be used in test command:@ \
271
272
273
274
275
276
277
278
279
280
     @@PTEST_CONFIG@@    \
     # test configuration suffix@ \
     @@PTEST_FILE@@   \
     # substituted by the test filename@ \
     @@PTEST_DIR@@    \
     # dirname of the test file@ \
     @@PTEST_NAME@@   \
     # basename of the test file@ \
     @@PTEST_NUMBER@@ \
     # test command number@] @ \
281
282
     @[<v 1>\
     Examples:@ \
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
     ptests@ \
     ptests -diff \"echo diff\" -examine        \
     # see again the list of tests that failed@ \
     ptests misc                              \
     # for a single test suite@ \
     ptests tests/misc/alias.c                \
     # for a single test@ \
     ptests -examine tests/misc/alias.c       \
     # to see the differences again@ \
     ptests -v -j 1                           \
     # to check the time taken by each test\
     @]@ @]"
;;

let umsg = "Usage: ptests [options] [names of test suites]";;

let rec argspec =
  [
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
    "-examine", Arg.Unit (fun () -> behavior := Examine) ,
    " Examine the logs that are different from oracles.";
    "-gui", Arg.Unit (fun () ->
        behavior := Gui;
        n := 1; (* Disable parallelism to see which GUI is launched *)
      ) ,
    " Start the tests in Frama-C's gui.";
    "-update", Arg.Unit (fun () -> behavior := Update) ,
    " Take the current logs as oracles.";
    "-show", Arg.Unit (fun () -> behavior := Show) ,
    " Show the results of the tests.";
    "-run", Arg.Unit (fun () -> behavior := Run) ,
    " (default) Delete logs, run tests, then examine logs different from \
     oracles.";
    "-v", Arg.Unit (fun () -> incr verbosity),
    " Increase verbosity (up to  twice)" ;
    "-dry-run", Arg.Unit (fun () -> dry_run := true),
    " Do not run commands (use with -v to print all commands which would be run)" ;
    "-diff", Arg.String (fun s -> do_diffs := s;
                          if !use_diff_as_cmp then do_cmp := s),
    "<command>  Use command for diffs" ;
    "-cmp", Arg.String (fun s -> do_cmp:=s),
    "<command>  Use command for comparison";
    "-make", Arg.String (fun s -> do_make := s;),
    "<command> Use command instead of make";
    "-use-diff-as-cmp",
    Arg.Unit (fun () -> use_diff_as_cmp:=true; do_cmp:=!do_diffs),
    " Use the diff command for performing comparisons";
    "-j", Arg.Int
      (fun i -> if i>=0
        then n := i
        else ( lock_printf "Option -j requires nonnegative argument@.";
               exit (-1))),
    "<n>  Use nonnegative integer n for level of parallelism" ;
    "-byte", Arg.Set use_byte,
    " Use bytecode toplevel";
    "-opt", Arg.Clear use_byte,
    " Use native toplevel (default)";
    "-config", Arg.Set_string special_config,
    " <name> Use special configuration and oracles";
    "-add-options", Arg.Set_string additional_options,
    "<options> Add additional options to be passed to the toplevels \
     that will be launched. <options> are added after standard test options";
    "-add-options-pre", Arg.Set_string additional_options_pre,
    "<options> Add additional options to be passed to the toplevels \
     that will be launched. <options> are added before standard test options.";
    "-add-options-post", Arg.Set_string additional_options,
    "Synonym of -add-options";
    "-exclude", Arg.String exclude,
    "<name> Exclude a test or a suite from the run";
    "-xunit", Arg.Set xunit,
    " Create a xUnit file named xunit.xml collecting results";
    "-error-code", Arg.Set do_error_code,
354
    " Exit with error code 1 if tests failed (useful for scripts)";
355
  ]
356
357
358
359
360
361
and help_msg () = Arg.usage (Arg.align argspec) umsg;;

let () =
  Arg.parse
    ((Arg.align
        (List.sort
362
363
364
           (fun (optname1, _, _) (optname2, _, _) ->
              compare optname1 optname2
           ) argspec)
365
366
367
368
369
370
371
372
373
374
375
     ) @ ["", Arg.Unit (fun () -> ()), example_msg;])
    make_test_suite umsg
;;


let fail s =
  Format.printf "Error: %s@." s;
  exit 2

(** split the filename into before including "tests" dir and after including "tests" dir
    NOTA: both part contains "tests" (one as suffix the other as prefix).
376
*)
377
378
379
let rec get_upper_test_dir initial dir =
  let tests = Filename.dirname dir in
  if tests = dir then
380
    (* root directory *)
381
382
383
    (fail (Printf.sprintf "Can't find a tests directory below %s" initial))
  else
    let base = Filename.basename dir in
384
385
386
387
388
    if base = "tests" then
      dir, "tests"
    else
      let tests, suffix = get_upper_test_dir initial tests in
      tests, Filename.concat suffix base
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512

let rec get_test_path = function
  | [] ->
    if Sys.file_exists "tests" && Sys.is_directory "tests" then "tests", []
    else begin
      Format.eprintf "No test path found. Aborting@.";
      exit 1
    end
  | [f] -> let tests, suffix = get_upper_test_dir f f in
    tests, [suffix]
  | a::l ->
    let tests, l = get_test_path l in
    let a_tests, a = get_upper_test_dir a a in
    if a_tests <> tests
    then fail (Printf.sprintf "All the tests should be inside the same tests directory")
    else tests, a::l

let test_path =
  let files, names = List.partition Sys.file_exists !suites in
  let tests, l = get_test_path files in
  let names = List.map (Filename.concat tests) names in
  suites := names@l;
  Sys.chdir (Filename.dirname tests);
  "tests"

let parse_config_line =
  let regexp_blank = Str.regexp "[ ]+" in
  fun (key, value) ->
    match key with
    | "DEFAULT_SUITES" ->
      let l = Str.split regexp_blank value in
      default_suites := List.map (Filename.concat test_path) l
    | "TOPLEVEL_PATH" ->
      toplevel_path := value
    | _ -> default_env key value (* Environnement variable that Frama-C reads*)


(** parse config files *)
let () =
  let config = "tests/ptests_config" in
  if Sys.file_exists config then begin
    try
      (*Parse the plugin configuration file for tests. Format is 'Key=value' *)
      let ch = open_in config in
      let regexp = Str.regexp "\\([^=]+\\)=\\(.*\\)" in
      while true do
        let line = input_line ch in
        if Str.string_match regexp line 0 then
          let key = Str.matched_group 1 line in
          let value = Str.matched_group 2 line in
          parse_config_line (key, value)
        else begin
          Format.eprintf "Cannot interpret line '%s' in ptests_config@." line;
          exit 1
        end
      done
    with
    | End_of_file ->
      if !toplevel_path = "" then begin
        Format.eprintf "Missing TOPLEVEL_PATH variable. Aborting.@.";
        exit 1
      end
  end
  else begin
    Format.eprintf
      "Cannot find configuration file %s. Aborting.@." config;
    exit 1
  end

(** Must be done after reading config *)
let () = if !behavior = Gui then change_toplevel_to_gui ()

(* redefine name if special configuration expected *)
let redefine_name name =
  if !special_config = "" then name else
    name ^ "_" ^ !special_config

let dir_config_file = redefine_name dir_config_file

let gen_make_file s dir file =
  Filename.concat (Filename.concat dir s) file

module SubDir: sig
  type t

  val get: t -> string

  val create: ?with_subdir:bool -> string (** dirname *) -> t
  (** By default, creates the needed subdirectories if absent.
      Anyway, fails if the given dirname doesn't exists *)

  val make_oracle_file: t -> string -> string
  val make_result_file: t -> string -> string
  val make_file: t -> string -> string
end = struct
  type t = string

  let get s = s

  let create_if_absent dir =
    if not (Sys.file_exists dir)
    then Unix.mkdir dir 0o750 (** rwxr-w--- *)
    else if not (Sys.is_directory dir)
    then fail (Printf.sprintf "the file %s exists but is not a directory" dir)

  let oracle_dirname = redefine_name "oracle"
  let result_dirname = redefine_name "result"

  let make_result_file = gen_make_file result_dirname
  let make_oracle_file = gen_make_file oracle_dirname
  let make_file = Filename.concat

  let create ?(with_subdir=true) dir =
    if not (Sys.file_exists dir && Sys.is_directory dir)
    then fail (Printf.sprintf "the directory %s must be an existing directory" dir);
    if (with_subdir) then begin
      create_if_absent (Filename.concat dir result_dirname);
      create_if_absent (Filename.concat dir oracle_dirname)
    end;
    dir

end

type execnow =
513
514
515
516
517
518
519
520
521
522
523
524
  {
    ex_cmd: string;      (** command to launch *)
    ex_log: string list; (** log files *)
    ex_bin: string list; (** bin files *)
    ex_dir: SubDir.t;    (** directory of test suite *)
    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) *)
    ex_done: bool ref;   (** has the command been already fully executed.
                             Shared between all copies of this EXECNOW. Do
                             NOT use a mutable field here, as execnows
                             are duplicated using OCaml 'with' syntax. *)
525
    ex_timeout: string;
526
  }
527

528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598

module Macros =
struct
  module StringMap = Map.Make (String)
  open StringMap

  type t = string StringMap.t

  let empty = StringMap.empty

  let macro_regex = Str.regexp "\\([^@]*\\)@\\([^@]*\\)@\\(.*\\)"

  let does_expand macros s =
    if !verbosity >=2 then begin
      lock_printf "looking for macros in string %s\n%!" s;
      lock_printf "Existing macros:\n%!";
      iter (fun s1 s2 -> lock_printf "%s => %s\n%!" s1 s2) macros;
      lock_printf "End macros\n%!";
    end;
    let rec aux n (ptest_file_matched,s as acc) =
      if Str.string_match macro_regex s n then begin
        let macro = Str.matched_group 2 s in
        let ptest_file_matched = ptest_file_matched || macro = "PTEST_FILE" in
        let start = Str.matched_group 1 s in
        let rest = Str.matched_group 3 s in
        let new_n = Str.group_end 1 in
        let n, new_s =
          if macro = "" then begin
            new_n + 1, String.sub s 0 new_n ^ "@" ^ rest
          end else begin
            try
              if !verbosity >= 2 then lock_printf "macro is %s\n%!" macro;
              let replacement =  find macro macros in
              if !verbosity >= 1 then
                lock_printf "replacement for %s is %s\n%!" macro replacement;
              new_n,
              String.sub s 0 n ^ start ^ replacement ^ rest
            with
            | Not_found -> Str.group_end 2 + 1, s
          end
        in
        if !verbosity >= 2 then lock_printf "new string is %s\n%!" new_s;
        let new_acc = ptest_file_matched, new_s in
        if n <= String.length new_s then aux n new_acc else new_acc
      end else acc
    in
    Mutex.lock str_mutex;
    try
      let res = aux 0 (false,s) in
      Mutex.unlock str_mutex; res
    with e ->
      lock_eprintf "Uncaught exception %s\n%!" (Printexc.to_string e);
      Mutex.unlock str_mutex;
      raise e

  let expand macros s =
    snd (does_expand macros s)

  let get ?(default="") name macros =
    try find name macros with Not_found -> default

  let add_list l map =
    List.fold_left (fun acc (k,v) -> add k v acc) map l

  let add_expand name def macros =
    add name (expand macros def) macros

  let append_expand name def macros =
    add name (get name macros ^ expand macros def) macros
end

599
600
601

(** configuration of a directory/test. *)
type config =
602
603
604
605
606
607
608
609
610
611
  {
    dc_test_regexp: string; (** regexp of test files. *)
    dc_execnow    : execnow list; (** command to be launched before
                                       the toplevel(s)
                                  *)
    dc_macros: Macros.t; (** existing macros. *)
    dc_default_toplevel   : string;
    (** full path of the default toplevel. *)
    dc_filter     : string option; (** optional filter to apply to
                                       standard output *)
612
    dc_toplevels    : (string * string * string list * Macros.t * string) list;
613
614
615
    (** toplevel full path, options to launch the toplevel on, and list
        of output files to monitor beyond stdout and stderr. *)
    dc_dont_run   : bool;
616
    dc_framac     : bool;
617
    dc_default_log: string list;
618
    dc_timeout: string
619
  }
620
621

let default_macros () =
622
623
624
625
626
  let l = [
    "frama-c", !toplevel_path;
    "PTEST_MAKE_MODULE", "make -s"
  ] in
  Macros.add_list l Macros.empty
627
628
629
630
631
632
633

let default_config () =
  { dc_test_regexp = test_file_regexp ;
    dc_macros = default_macros ();
    dc_execnow = [];
    dc_filter = None ;
    dc_default_toplevel = !toplevel_path;
634
    dc_toplevels = [ !toplevel_path, default_options, [], Macros.empty, "" ];
635
    dc_dont_run = false;
636
    dc_framac = true;
637
638
    dc_default_log = [];
    dc_timeout = "";
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
  }

let launch command_string =
  if !dry_run then 0 (* do not run command; return as if no error *)
  else
    let result = system command_string in
    match result with
    | Unix.WEXITED 127 ->
      lock_printf "%% Couldn't execute command. Retrying once.@.";
      Thread.delay 0.125;
      ( match system command_string with
          Unix.WEXITED r when r <> 127 -> r
        | _ -> lock_printf "%% Retry failed with command:@\n%s@\nStopping@."
                 command_string ;
          exit 1 )
    | Unix.WEXITED r -> r
    | Unix.WSIGNALED s ->
      lock_printf
        "%% SIGNAL %d received while executing command:@\n%s@\nStopping@."
        s command_string ;
      exit 1
    | Unix.WSTOPPED s ->
      lock_printf
        "%% STOP %d received while executing command:@\n%s@\nStopping@."
        s command_string;
      exit 1


667
let scan_execnow ~once dir ex_timeout (s:string) =
668
669
670
671
  let rec aux (s:execnow) =
    try
      Scanf.sscanf s.ex_cmd "%_[ ]LOG%_[ ]%[-A-Za-z0-9_',+=:.\\@@]%_[ ]%s@\n"
        (fun name cmd ->
672
           aux { s with ex_cmd = cmd; ex_log = name :: s.ex_log })
673
    with Scanf.Scan_failure _ ->
674
675
676
677
678
679
680
681
682
683
684
685
    try
      Scanf.sscanf s.ex_cmd "%_[ ]BIN%_[ ]%[A-Za-z0-9_.\\-@@]%_[ ]%s@\n"
        (fun name cmd ->
           aux { s with ex_cmd = cmd; ex_bin = name :: s.ex_bin })
    with Scanf.Scan_failure _ ->
    try
      Scanf.sscanf s.ex_cmd "%_[ ]make%_[ ]%s@\n"
        (fun cmd ->
           let s = aux ({ s with ex_cmd = cmd; }) in
           { s with ex_cmd = !do_make^" "^cmd; } )
    with Scanf.Scan_failure _ ->
      s
686
687
688
689
690
691
692
  in
  aux
    { ex_cmd = s;
      ex_log = [];
      ex_bin = [];
      ex_dir = dir;
      ex_once = once;
693
694
695
      ex_done = ref false;
      ex_timeout;
    }
696
697
698
699

(* the default toplevel for the current level of options. *)
let current_default_toplevel = ref !toplevel_path
let current_default_log = ref []
700
701
let current_default_cmds =
  ref [!toplevel_path,default_options,[], Macros.empty, ""]
702
703
704
705
706
707

let make_custom_opts =
  let space = Str.regexp " " in
  fun stdopts s ->
    let rec aux opts s =
      try
708
        Scanf.sscanf s "%_[ ]%1[+#\\-]%_[ ]%S%_[ ]%s@\n"
709
          (fun c opt rem ->
710
711
712
713
714
             match c with
             | "+" -> aux (opt :: opts) rem
             | "#" -> aux (opts @ [ opt ]) rem
             | "-" -> aux (List.filter (fun x -> x <> opt) opts) rem
             | _ -> assert false (* format of scanned string disallow it *))
715
716
      with
      | Scanf.Scan_failure _ ->
717
718
719
        if s <> "" then
          lock_eprintf "unknown STDOPT configuration string: %s\n%!" s;
        opts
720
721
722
723
724
725
726
727
728
729
730
731
      | End_of_file -> opts
    in
    (* NB: current settings does not allow to remove a multiple-argument
       option (e.g. -verbose 2).
    *)
    (* revert the initial list, as it will be reverted back in the end. *)
    let opts =
      aux (List.rev (str_split space stdopts)) s
    in
    (* preserve options ordering *)
    List.fold_right (fun x s -> s ^ " " ^ x) opts ""

732
733
734

(* how to process options *)
let config_exec ~once dir s current =
735
736
737
  { current with
    dc_execnow =
      scan_execnow ~once dir current.dc_timeout s :: current.dc_execnow }
738
739

let config_macro _dir s current =
740
741
742
743
  let regex = Str.regexp "[ \t]*\\([^ \t@]+\\)\\([ \t]+\\(.*\\)\\|$\\)" in
  Mutex.lock str_mutex;
  if Str.string_match regex s 0 then begin
    let name = Str.matched_group 1 s in
744
    let def =
745
746
747
748
749
      try Str.matched_group 3 s with Not_found -> (* empty text *) ""
    in
    Mutex.unlock str_mutex;
    if !verbosity >= 1 then
      lock_printf "new macro %s with definition %s\n%!" name def;
750
    { current with dc_macros = Macros.add_expand name def current.dc_macros }
751
752
753
  end else begin
    Mutex.unlock str_mutex;
    lock_eprintf "cannot understand MACRO definition: %s\n%!" s;
754
    current
755
756
  end

757
758
759
760
761
762
763
let config_module dir s current =
  let make_cmd = "@PTEST_MAKE_MODULE@ " ^ s in
  let make_cmd = Macros.expand current.dc_macros make_cmd in
  let current = config_exec ~once:true dir make_cmd current in
  let k = "PTEST_LOAD_MODULES" and v = " -load-module " ^ s in
  { current with dc_macros = Macros.append_expand k v current.dc_macros }

764
765
let config_options =
  [ "CMD",
766
    (fun _ s current ->
767
768
769
770
       { current with dc_default_toplevel = s});

    "OPT",
    (fun _ s current ->
771
772
773
774
775
776
777
       let t =
         current.dc_default_toplevel,
         s,
         current.dc_default_log,
         current.dc_macros,
         current.dc_timeout
       in
778
       { current with
779
780
781
         (*           dc_default_toplevel = !current_default_toplevel;*)
         dc_default_log = !current_default_log;
         dc_toplevels = t :: current.dc_toplevels });
782
783
784
785
786

    "STDOPT",
    (fun _ s current ->
       let new_top =
         List.map
787
           (fun (cmd,opts, log, macros,_) ->
788
              cmd, make_custom_opts opts s, log @ current.dc_default_log,
Virgile Prevosto's avatar
Virgile Prevosto committed
789
              current.dc_macros, current.dc_timeout)
790
791
792
           !current_default_cmds
       in
       { current with dc_toplevels = new_top @ current.dc_toplevels;
793
                      dc_default_log = !current_default_log });
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809

    "FILEREG",
    (fun _ s current -> { current with dc_test_regexp = s });

    "FILTER",
    (fun _ s current -> { current with dc_filter = Some s });

    "GCC",
    (fun _ _ acc -> acc);

    "COMMENT",
    (fun _ _ acc -> acc);

    "DONTRUN",
    (fun _ s current -> { current with dc_dont_run = true });

810
811
812
813
    "EXECNOW", config_exec ~once:true;
    "EXEC", config_exec ~once:false;
    "MACRO", config_macro;
    "MODULE", config_module;
814
815
    "LOG",
    (fun _ s current ->
816
817
818
       { current with dc_default_log = s :: current.dc_default_log });
    "TIMEOUT",
    (fun _ s current -> { current with dc_timeout = s });
819
820
    "NOFRAMAC",
    (fun _ _ current -> { current with dc_toplevels = []; dc_framac = false; });
821
822
823
824
825
826
827
828
829
830
831
832
833
  ]

let scan_options dir scan_buffer default =
  let r =
    ref { default with dc_toplevels = [] }
  in
  current_default_toplevel := default.dc_default_toplevel;
  current_default_log := default.dc_default_log;
  current_default_cmds := List.rev default.dc_toplevels;
  let treat_line s =
    try
      Scanf.sscanf s "%[ *]%[A-Za-z0-9]: %s@\n"
        (fun _ name opt ->
834
835
836
837
           try
             r := (List.assoc name config_options) dir opt !r
           with Not_found ->
             lock_eprintf "@[unknown configuration option: %s@\n%!@]" name)
838
839
    with
    | Scanf.Scan_failure _ ->
840
841
842
      if str_string_match end_comment s 0
      then raise End_of_file
      else ()
843
    | End_of_file -> (* ignore blank lines. *) ()
844
845
846
  in
  try
    while true do
847
      if Scanf.Scanning.end_of_input scan_buffer then raise End_of_file;
848
849
850
851
852
      Scanf.bscanf scan_buffer "%s@\n" treat_line
    done;
    assert false
  with
    End_of_file ->
853
    (match !r.dc_toplevels with
854
     | [] when !r.dc_framac -> { !r with dc_toplevels = default.dc_toplevels }
855
     | l -> { !r with dc_toplevels = List.rev l })
856
857
858

let split_config = Str.regexp ",[ ]*"

859
860
861
862
863
let is_config name =
  let prefix = "run.config" in
  let len = String.length prefix in
  String.length name >= len && String.sub name 0 len = prefix

864
865
866
867
868
869
870
let scan_test_file default dir f =
  let f = SubDir.make_file dir f in
  let exists_as_file =
    try
      (Unix.lstat f).Unix.st_kind = Unix.S_REG
    with Unix.Unix_error _ | Sys_error _ -> false
  in
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
  if exists_as_file then begin
    let scan_buffer = Scanf.Scanning.open_in f in
    let rec scan_config () =
      (* space in format string matches any number of whitespace *)
      Scanf.bscanf scan_buffer " /* %s@\n"
        (fun names ->
           let is_current_config name =
             name = "run.config*" ||
             name = "run.config" && !special_config = ""  ||
             name = "run.config_" ^ !special_config
           in
           let configs = Str.split split_config (String.trim names) in
           if List.exists is_current_config configs then
             (* Found options for current config! *)
             scan_options dir scan_buffer default
           else (* config name does not match: eat config and continue.
                   But only if the comment is still opened by the end of
888
                   the line and we are indeed reading a config
889
                *)
890
891
             (if List.exists is_config configs &&
                 not (str_string_match end_comment names 0) then
892
893
894
895
896
897
898
899
900
901
902
903
904
                ignore (scan_options dir scan_buffer default);
              scan_config ()))
    in
    try
      let options =  scan_config () in
      Scanf.Scanning.close_in scan_buffer;
      options
    with End_of_file | Scanf.Scan_failure _ ->
      Scanf.Scanning.close_in scan_buffer;
      default
  end else
    (* if the file has disappeared, don't try to run it... *)
    { default with dc_dont_run = true }
905
906

type toplevel_command =
907
908
909
910
911
912
913
914
915
  { macros: Macros.t;
    mutable log_files: string list;
    file : string ;
    nb_files : int ;
    options : string ;
    toplevel: string ;
    filter : string option ;
    directory : SubDir.t ;
    n : int;
916
917
    execnow:bool;
    timeout: string;
918
  }
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935

type command =
  | Toplevel of toplevel_command
  | Target of execnow * command Queue.t

type log = Err | Res

type diff =
  | Command_error of toplevel_command * log
  | Target_error of execnow
  | Log_error of SubDir.t (** directory *) * string (** file *)

type cmps =
  | Cmp_Toplevel of toplevel_command
  | Cmp_Log of SubDir.t (** directory *) * string (** file *)

type shared =
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
  { lock : Mutex.t ;
    mutable building_target : bool ;
    target_queue : command Queue.t ;
    commands_empty : Condition.t ;
    work_available : Condition.t ;
    diff_available : Condition.t ;
    mutable commands : command Queue.t ; (* file, options, number *)
    cmps : cmps Queue.t ;
    (* command that has finished its execution *)
    diffs : diff Queue.t ;
    (* cmp that showed some difference *)
    mutable commands_finished : bool ;
    mutable cmp_finished : bool ;
    mutable summary_time : float ;
    mutable summary_run : int ;
    mutable summary_ok : int ;
    mutable summary_log : int;
  }
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985

let shared =
  { lock = Mutex.create () ;
    building_target = false ;
    target_queue = Queue.create () ;
    commands_empty = Condition.create () ;
    work_available = Condition.create () ;
    diff_available = Condition.create () ;
    commands = Queue.create () ;
    cmps = Queue.create () ;
    diffs = Queue.create () ;
    commands_finished = false ;
    cmp_finished = false ;
    summary_time = (Unix.times()).Unix.tms_cutime ;
    summary_run = 0 ;
    summary_ok = 0 ;
    summary_log = 0 }

let unlock () = Mutex.unlock shared.lock

let lock () = Mutex.lock shared.lock

let catenate_number nb_files prefix n =
  if nb_files > 1
  then prefix ^ "." ^ (string_of_int n)
  else prefix

let name_without_extension command =
  try
    (Filename.chop_extension command.file)
  with
    Invalid_argument _ ->
986
987
    fail ("this test file does not have any extension: " ^
          command.file)
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011

let gen_prefix gen_file cmd =
  let prefix = gen_file cmd.directory (name_without_extension cmd) in
  catenate_number cmd.nb_files prefix cmd.n

let log_prefix = gen_prefix SubDir.make_result_file
let oracle_prefix = gen_prefix SubDir.make_oracle_file

let get_ptest_file cmd = SubDir.make_file cmd.directory cmd.file

let get_macros cmd =
  let ptest_config =
    if !special_config = "" then "" else "_" ^ !special_config
  in
  let ptest_file = get_ptest_file cmd in
  let ptest_name =
    try Filename.chop_extension cmd.file
    with Invalid_argument _ -> cmd.file
  in
  let macros =
    [ "PTEST_CONFIG", ptest_config;
      "PTEST_DIR", SubDir.get cmd.directory;
      "PTEST_RESULT",
      SubDir.get cmd.directory ^ "/" ^ redefine_name "result";
1012
      "PTEST_FILE", Filename.sanitize ptest_file;
1013
1014
1015
1016
      "PTEST_NAME", ptest_name;
      "PTEST_NUMBER", string_of_int cmd.n;
    ]
  in
1017
  Macros.add_list macros cmd.macros
1018

1019
1020
1021
1022
1023
1024
let contains_frama_c_binary_name =
  Str.regexp "[^( ]*\\(toplevel\\|viewer\\|frama-c-gui\\|frama-c[^-]\\).*"

let frama_c_binary_name =
  Str.regexp "\\([^ ]*\\(toplevel\\|viewer\\|frama-c-gui\\|frama-c\\)\\(\\.opt\\|\\.byte\\|\\.exe\\)?\\)"

1025
1026
let basic_command_string =
  fun command ->
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
  let macros = get_macros command in
  let logfiles = List.map (Macros.expand macros) command.log_files in
  command.log_files <- logfiles;
  let has_ptest_file_t, toplevel =
    Macros.does_expand macros command.toplevel
  in
  let has_ptest_file_o, options = Macros.does_expand macros command.options in
  let toplevel = if !use_byte then opt_to_byte toplevel else toplevel in
  let toplevel, contains_frama_c_binary =
    str_string_match_and_replace contains_frama_c_binary_name
      frama_c_binary_name ~suffix:" -check" toplevel
  in
  let options =
    if contains_frama_c_binary
    then begin
      let opt_modules = Macros.expand macros
          (Macros.get "PTEST_LOAD_MODULES" macros) in
      let opt_pre = Macros.expand macros !additional_options_pre in
      let opt_post = Macros.expand macros !additional_options in
      opt_modules ^ " " ^ opt_pre ^ " " ^ options ^ " " ^ opt_post
    end else options
  in
  let options = if !use_byte then opt_to_byte_options options else options in
  let raw_command =
    if has_ptest_file_t || has_ptest_file_o || command.execnow then
      toplevel ^ " " ^ options
    else begin
      let file = Filename.sanitize @@ get_ptest_file command in
      toplevel ^ " " ^ file ^ " " ^ options
    end
  in
  if command.timeout = "" then raw_command
  else "ulimit -t " ^ command.timeout ^ " && " ^ raw_command
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100

(* Searches for executable [s] in the directories contained in the PATH
   environment variable. Returns [None] if not found, or
   [Some <fullpath>] otherwise. *)
let find_in_path s =
  let trim_right s =
    let n = ref (String.length s - 1) in
    let last_char_to_keep =
      try
        while !n > 0 do
          if String.get s !n <> ' ' then raise Exit;
          n := !n - 1
        done;
        0
      with Exit -> !n
    in
    String.sub s 0 (last_char_to_keep+1)
  in
  let s = trim_right s in
  let path_separator = if Sys.os_type = "Win32" then ";" else ":" in
  let re_path_sep = Str.regexp path_separator in
  let path_dirs = Str.split re_path_sep (Sys.getenv "PATH") in
  let found = ref "" in
  try
    List.iter (fun dir ->
        let fullname = dir ^ Filename.dir_sep ^ s in
        if Sys.file_exists fullname then begin
          found := fullname;
          raise Exit
        end
      ) path_dirs;
    None
  with Exit ->
    Some !found

let command_string command =
  let log_prefix = log_prefix command in
  let errlog = log_prefix ^ ".err.log" in
  let stderr = match command.filter with
      None -> errlog
    | Some _ ->
1101
1102
1103
1104
1105
      let stderr =
        Filename.temp_file (Filename.basename log_prefix) ".err.log"
      in
      at_exit (fun () ->  unlink stderr);
      stderr
1106
1107
1108
1109
  in
  let filter = match command.filter with
    | None -> None
    | Some filter ->
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
      let len = String.length filter in
      let rec split_filter i =
        if i < len && filter.[i] = ' ' then split_filter (i+1)
        else
          try
            let idx = String.index_from filter i ' ' in
            String.sub filter i idx,
            String.sub filter idx (len - idx)
          with Not_found ->
            String.sub filter i (len - i), ""
      in
      let exec_name, params = split_filter 0 in
      let exec_name =
        if Sys.file_exists exec_name || not (Filename.is_relative exec_name)
        then exec_name
        else
          match find_in_path exec_name with
          | Some full_exec_name -> full_exec_name
          | None ->
            Filename.concat
              (Filename.dirname (Filename.dirname log_prefix))
              (Filename.basename exec_name)
      in
      Some (exec_name ^ params)
1134
1135
1136
  in
  let command_string = basic_command_string command in
  let command_string =
1137
    command_string ^ " 2>" ^ (Filename.sanitize stderr)
1138
1139
1140
1141
1142
  in
  let command_string = match filter with
    | None -> command_string
    | Some filter -> command_string ^ " | " ^ filter
  in
1143
  let res = Filename.sanitize (log_prefix ^ ".res.log") in
1144
  let command_string = command_string ^ " >" ^ res in
1145
1146
  let command_string =
    match command.timeout with
Virgile Prevosto's avatar
Virgile Prevosto committed
1147
1148
1149
    | "" -> command_string
    | s ->
      Printf.sprintf
1150
        "%s; if test $? -gt 127; then \
Virgile Prevosto's avatar
Virgile Prevosto committed
1151
1152
1153
         echo 'TIMEOUT (%s); ABORTING EXECUTION' > %s; \
         fi"
        command_string s (Filename.sanitize stderr)
1154
  in
1155
1156
1157
  let command_string = match filter with
    | None -> command_string
    | Some filter ->
1158
1159
1160
1161
1162
1163
      Printf.sprintf "%s && %s < %s >%s && rm -f %s"
        command_string
        filter
        (Filename.sanitize stderr)
        (Filename.sanitize errlog)
        (Filename.sanitize stderr)
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
  in
  command_string

let update_log_files dir file =
  mv (SubDir.make_result_file dir file) (SubDir.make_oracle_file dir file)

let update_toplevel_command command =

  let log_prefix = log_prefix command in
  let oracle_prefix = oracle_prefix command in
  (* Update oracle *)
  mv (log_prefix ^ ".res.log") (oracle_prefix ^ ".res.oracle");
  (* Is there an error log ? *)
  begin try
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
      let log = log_prefix ^ ".err.log"
      and oracle = oracle_prefix ^ ".err.oracle"
      in
      if is_file_empty_or_nonexisting log then
        (* No, remove the error oracle *)
        unlink ~silent:false oracle
      else
        (* Yes, update the error oracle*)
        mv log oracle
    with (* Possible error in [is_file_empty] *)
      Unix.Unix_error _ -> ()
1189
1190
  end;
  let macros = get_macros command in
1191
  let log_files = List.map (Macros.expand macros) command.log_files
1192
1193
1194
1195
1196
1197
  in
  List.iter (update_log_files command.directory) log_files

let rec update_command = function
    Toplevel cmd -> update_toplevel_command cmd
  | Target (execnow,cmds) ->
1198
1199
    List.iter (update_log_files execnow.ex_dir) execnow.ex_log;
    Queue.iter update_command cmds
1200
1201
1202
1203
1204
1205
1206
1207

let remove_execnow_results execnow =
  List.iter
    (fun f -> unlink (SubDir.make_result_file execnow.ex_dir f))
    (execnow.ex_bin @ execnow.ex_log)

module Make_Report(M:sig type t end)=struct
  module H=Hashtbl.Make
1208
1209
1210
1211
1212
1213
1214
      (struct
        type t = toplevel_command
        let project cmd = (cmd.directory,cmd.file,cmd.n)
        let compare c1 c2 = compare (project c1) (project c2)
        let equal c1 c2 =  (project c1)=(project c2)
        let hash c = Hashtbl.hash (project c)
      end)
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
  let tbl = H.create 774
  let m = Mutex.create ()
  let record cmd (v:M.t) =
    if !xunit then begin
      Mutex.lock m;
      H.add tbl cmd v;
      Mutex.unlock m
    end
  let iter f =
    Mutex.lock m;
    H.iter f tbl;
    Mutex.unlock m
  let find k = H.find tbl k
  let remove k = H.remove tbl k

end
module Report_run=Make_Report(struct type t=int*float
(* At some point will contain the running time*)
1233
  end)
1234
1235
1236
1237
1238
1239
1240

let report_run cmp r = Report_run.record cmp r
module Report_cmp=Make_Report(struct type t=int*int end)
let report_cmp = Report_cmp.record
let pretty_report fmt =
  Report_run.iter
    (fun test (_run_result,time_result) ->
1241
1242
1243
1244
1245
1246
       Format.fprintf fmt
         "<testcase classname=%S name=%S time=\"%f\">%s</testcase>@."
         (Filename.basename (SubDir.get test.directory)) test.file time_result
         (let res,err = Report_cmp.find test in
          Report_cmp.remove test;
          (if res=0 && err=0 then "" else
1247
1248
1249
1250
1251
1252
1253
1254
1255
             Format.sprintf "<failure type=\"Regression\">%s</failure>"
               (if res=1 then "Stdout oracle difference"
                else if res=2 then "Stdout System Error (missing oracle?)"
                else if err=1 then "Stderr oracle difference"
                else if err=2 then "Stderr System Error (missing oracle?)"
                else "Unexpected errror"))));
  (* Test that were compared but not runned *)
  Report_cmp.iter
    (fun test (res,err) ->
1256
1257
1258
1259
       Format.fprintf fmt
         "<testcase classname=%S name=%S>%s</testcase>@."
         (Filename.basename (SubDir.get test.directory)) test.file
         (if res=0 && err=0 then "" else
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
            Format.sprintf "<failure type=\"Regression\">%s</failure>"
              (if res=1 then "Stdout oracle difference"
               else if res=2 then "Stdout System Error (missing oracle?)"
               else if err=1 then "Stderr oracle difference"
               else if err=2 then "Stderr System Error (missing oracle?)"
               else "Unexpected errror")))
let xunit_report () =
  if !xunit then begin
    let out = open_out_bin "xunit.xml" in
    let fmt = Format.formatter_of_out_channel out in
    Format.fprintf fmt
      "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\
1272
1273
       @\n<testsuite errors=\"0\" failures=\"%d\" name=\"%s\" tests=\"%d\" time=\"%f\" timestamp=\"%f\">\
       @\n%t</testsuite>@."
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
      (shared.summary_log-shared.summary_ok)
      "Frama-C"
      shared.summary_log
      ((Unix.times()).Unix.tms_cutime -. shared.summary_time)
      (Unix.gettimeofday ())
      pretty_report;
    close_out out;
  end


let do_command command =
  match command with
  | Toplevel command ->
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
    (* Update : copy the logs. Do not enqueue any cmp
       Run | Show: launch the command, then enqueue the cmp
       Gui: launch the command in the gui
       Examine : just enqueue the cmp *)
    if !behavior = Update
    then update_toplevel_command command
    else begin
      (* Run, Show, Gui or Examine *)
      if !behavior = Gui then begin
        (* basic_command_string does not redirect the outputs, and does
           not overwrite the result files *)
        let basic_command_string = basic_command_string command in
        lock_printf "%% launch %s@." basic_command_string ;
        ignore (launch basic_command_string)
      end
1302
      else begin
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
        (* command string also replaces macros in logfiles names, which
           is useful for Examine as well. *)
        let command_string = command_string command in
        if !behavior <> Examine
        then begin
          if !verbosity >= 1
          then lock_printf "%% launch %s@." command_string ;
          let launch_result = launch command_string in
          let time = 0. (* Individual time is difficult to compute correctly
                           for now, and currently unused *) in
          report_run command (launch_result, time)
        end;
        lock ();
        shared.summary_run <- succ shared.summary_run ;
        Queue.push (Cmp_Toplevel command) shared.cmps;
        List.iter
          (fun f -> Queue.push (Cmp_Log (command.directory, f)) shared.cmps)
          command.log_files;
        unlock ()
      end
    end
  | Target (execnow, cmds) ->
    let continue res =
      lock();
      shared.summary_log <- succ shared.summary_log;
      if res = 0
      then begin
        shared.summary_ok <- succ shared.summary_ok;
        Queue.transfer shared.commands cmds;
        shared.commands <- cmds;
        shared.building_target <- false;
        Condition.broadcast shared.work_available;
        if !behavior = Examine || !behavior = Run
        then begin
1337
          List.iter
1338
1339
            (fun f -> Queue.push (Cmp_Log(execnow.ex_dir, f)) shared.cmps)
            execnow.ex_log
1340
1341
        end
      end
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
      else begin
        let rec treat_cmd = function
            Toplevel cmd ->
            shared.summary_run <- shared.summary_run + 1;
            let log_prefix = log_prefix cmd in
            unlink (log_prefix ^ ".res.log ")
          | Target (execnow,cmds) ->
            shared.summary_run <- succ shared.summary_run;
            remove_execnow_results execnow;
            Queue.iter treat_cmd cmds
        in
        Queue.iter treat_cmd cmds;
        Queue.push (Target_error execnow) shared.diffs;
        shared.building_target <- false;
        Condition.signal shared.diff_available
      end;
      unlock()
    in
1360

1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
    if !behavior = Update then begin
      update_command command;
      lock ();
      shared.building_target <- false;
      Condition.signal shared.work_available;
      unlock ();
    end else
      begin
        if !behavior <> Examine && not (!(execnow.ex_done) && execnow.ex_once)
        then begin
          remove_execnow_results execnow;
          let cmd =
            if !use_byte then
              execnow_opt_to_byte execnow.ex_cmd
1375
            else
1376
1377
              execnow.ex_cmd
          in
1378
          if !verbosity >= 1 || !behavior = Show then begin
1379
1380
            lock_printf "%% launch %s@." cmd;
          end;
1381
          shared.summary_run <- succ shared.summary_run;
1382
1383
1384
1385
1386
1387
1388
1389
          let r = launch cmd in
          (* mark as already executed. For EXECNOW in test_config files,
             other instances (for example another test of the same
             directory), won't relaunch the command. For EXECNOW in
             stand-alone tests, there is only one copy of the EXECNOW
             anyway *)
          execnow.ex_done := true;
          continue r
1390
        end
1391
1392
1393
        else
          continue 0
      end
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430

let log_ext = function Res -> ".res" | Err -> ".err"

let launch_and_check_compare_file diff ~cmp_string ~log_file ~oracle_file =
  lock();
  shared.summary_log <- shared.summary_log + 1;
  unlock();
  let res = launch cmp_string in
  begin
    match res with
      0 ->
      lock();
      shared.summary_ok <- shared.summary_ok + 1;
      unlock()
    | 1 ->
      lock();
      Queue.push diff shared.diffs;
      Condition.signal shared.diff_available;
      unlock()
    | 2 ->
      lock_printf
        "%% System error while comparing. Maybe one of the files is missing...@\n%s or %s@."
        log_file oracle_file
    | n ->
      lock_printf
        "%% Comparison function exited with code %d for files %s and %s. \
         Allowed exit codes are 0 (no diff), 1 (diff found) and \
         2 (system error). This is a fatal error.@." n log_file oracle_file;
      exit 2
  end;
  res

let check_file_is_empty_or_nonexisting diff ~log_file =
  if is_file_empty_or_nonexisting log_file then
    0
  else begin
    lock();
1431
1432
    (* signal that there's a problem. *)
    shared.summary_log <- shared.summary_log + 1;
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
    Queue.push diff shared.diffs;
    Condition.signal shared.diff_available;
    unlock();
    1
  end

let compare_one_file cmp log_prefix oracle_prefix log_kind =
  if !behavior = Show
  then begin
    lock();
    Queue.push (Command_error(cmp,log_kind)) shared.diffs;
    Condition.signal shared.diff_available;
    unlock();
    -1
  end else
    let ext = log_ext log_kind in
1449
1450
    let log_file = Filename.sanitize (log_prefix ^ ext ^ ".log") in
    let oracle_file = Filename.sanitize (oracle_prefix ^ ext ^ ".oracle") in
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
    if log_kind = Err && not (Sys.file_exists oracle_file) then
      check_file_is_empty_or_nonexisting (Command_error (cmp,log_kind)) ~log_file
    else begin
      let cmp_string =
        !do_cmp ^ " " ^ log_file ^ " " ^ oracle_file ^ " > /dev/null 2> /dev/null"
      in
      if !verbosity >= 2 then lock_printf "%% cmp%s (%d) :%s@."
          ext
          cmp.n
          cmp_string;
      launch_and_check_compare_file (Command_error (cmp,log_kind))
        ~cmp_string ~log_file ~oracle_file
    end

let compare_one_log_file dir file =
  if !behavior = Show
  then begin
    lock();
    Queue.push (Log_error(dir,file)) shared.diffs;
    Condition.signal shared.diff_available;
    unlock()
  end else
1473
1474
    let log_file = Filename.sanitize (SubDir.make_result_file dir file) in
    let oracle_file = Filename.sanitize (SubDir.make_oracle_file dir file) in
1475
1476
1477
1478
1479
1480
1481
    let cmp_string = !do_cmp ^ " " ^ log_file ^ " " ^ oracle_file ^ " > /dev/null 2> /dev/null" in
    if !verbosity >= 2 then lock_printf "%% cmplog: %s / %s@." (SubDir.get dir) file;
    ignore (launch_and_check_compare_file (Log_error (dir,file))
              ~cmp_string ~log_file ~oracle_file)

let do_cmp = function
  | Cmp_Toplevel cmp ->
1482
1483
1484
1485
1486
    let log_prefix = log_prefix cmp in
    let oracle_prefix = oracle_prefix cmp in
    let res = compare_one_file cmp log_prefix oracle_prefix Res in
    let err = compare_one_file cmp log_prefix oracle_prefix Err in
    report_cmp cmp (res,err)
1487
  | Cmp_Log(dir, f) ->
1488
    ignore (compare_one_log_file dir f)
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499

let worker_thread () =
  while true do
    lock () ;
    if (Queue.length shared.commands) + (Queue.length shared.cmps) < !n
    then Condition.signal shared.commands_empty;
    try
      let cmp = Queue.pop shared.cmps in
      unlock () ;
      do_cmp cmp
    with Queue.Empty ->
1500
1501
1502
1503
1504
1505
1506
1507
    try
      let rec real_command () =
        let command =
          try
            if shared.building_target then raise Queue.Empty;
            Queue.pop shared.target_queue
          with Queue.Empty ->
            Queue.pop shared.commands
1508
        in
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
        match command with
          Target _ ->
          if shared.building_target
          then begin
            Queue.push command shared.target_queue;
            real_command()
          end
          else begin
            shared.building_target <- true;
            command
          end
        | _ -> command
      in
      let command = real_command() in
      unlock () ;
      do_command command
    with Queue.Empty ->
      if shared.commands_finished
      && Queue.is_empty shared.target_queue
      && not shared.building_target
      (* a target being built would mean work can still appear *)
1530

1531
      then (unlock () ; Thread.exit ());
1532

1533
1534
      Condition.signal shared.commands_empty;
      (* we still have the lock at this point *)
1535

1536
1537
1538
      Condition.wait shared.work_available shared.lock;
      (* this atomically releases the lock and suspends
         the thread on the condition work_available *)
1539

1540
      unlock ();
1541
1542
  done

1543
1544
1545
1546
1547
let diff_check_exist old_file new_file =
  if Sys.file_exists old_file then begin
    if Sys.file_exists new_file then begin
      !do_diffs ^ " " ^ old_file ^ " " ^ new_file
    end else begin
1548
1549
      "echo \"+++ " ^ new_file ^ " does not exist. Showing " ^
      old_file ^ "\";" ^ " cat " ^ old_file
1550
1551
    end
  end else begin
1552
1553
    "echo \"--- " ^ old_file ^ " does not exist. Showing " ^
    new_file ^ "\";" ^ " cat " ^ new_file
1554
1555
  end

1556
let do_diff = function
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
  | Command_error (diff, kind) ->
    let log_prefix = log_prefix diff in
    let log_ext = log_ext kind in
    let log_file = Filename.sanitize (log_prefix ^ log_ext ^ ".log") in
    let command_string = command_string diff in
    lock_printf "%tCommand:@\n%s@." print_default_env command_string;
    if !behavior = Show
    then ignore (launch ("cat " ^ log_file))
    else
      let oracle_prefix = oracle_prefix diff in
      let oracle_file =
        Filename.sanitize (oracle_prefix ^ log_ext ^ ".oracle")
      in
      let diff_string = diff_check_exist oracle_file log_file in
      ignore (launch diff_string)
1572
  | Target_error execnow ->
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
    lock_printf "Custom command failed: %s@\n" execnow.ex_cmd;
    let print_redirected out redir_str =
      try
        ignore (Str.search_forward (Str.regexp redir_str) execnow.ex_cmd 0);
        let file = Str.matched_group 1 execnow.ex_cmd in
        lock_printf "%s redirected to %s:@\n" out file;
        if not (Sys.file_exists file) then
          lock_printf "error: file does not exist: %s:@\n" file
        else
          ignore (launch ("cat " ^ file));
      with Not_found -> ()
    in
    print_redirected "stdout" "[^2]> ?\\([-a-zA-Z0-9_/.]+\\)";
    print_redirected "stderr" "2> ?\\([-a-zA-Z0-9_/.]+\\)";
1587
  | Log_error(dir, file) ->
1588
1589
1590
1591
1592
1593
1594
1595
1596
    let result_file =
      Filename.sanitize (SubDir.make_result_file dir file)
    in
    lock_printf "Log of %s:@." result_file;
    if !behavior = Show
    then ignore (launch ("cat " ^ result_file))
    else
      let oracle_file =
        Filename.sanitize (SubDir.make_oracle_file dir file)
1597
      in
1598
1599
      let diff_string = diff_check_exist oracle_file result_file in
      ignore (launch diff_string)
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628

let diff_thread () =
  lock () ;
  while true do
    try
      let diff = Queue.pop shared.diffs in
      unlock ();
      do_diff diff;
      lock ()
    with Queue.Empty ->
      if shared.cmp_finished then (unlock () ; Thread.exit ());

      Condition.wait shared.diff_available shared.lock
      (* this atomically releases the lock and suspends
         the thread on the condition cmp_available *)
  done

let test_pattern config =
  let regexp = Str.regexp config.dc_test_regexp in
  fun file -> str_string_match regexp file 0

let files = Queue.create ()

(* test for a possible toplevel configuration. *)
let default_config () =
  let general_config_file = Filename.concat test_path dir_config_file in
  if Sys.file_exists general_config_file
  then begin
    let scan_buffer = Scanf.Scanning.from_file general_config_file in
1629
1630
1631
1632
    scan_options
      (SubDir.create ~with_subdir:false Filename.current_dir_name)
      scan_buffer
      (default_config ())
1633
1634
1635
  end
  else default_config ()

1636
1637
1638
1639
1640
1641
1642
(* if we have some references to directories in the default config, they
   need to be adapted to the actual test directory. *)
let update_dir_ref dir config =
  let update_execnow e = { e with ex_dir = dir } in
  let dc_execnow = List.map update_execnow config.dc_execnow in
  { config with dc_execnow }

1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
let () =
  (* enqueue the test files *)
  let default_suites () =
    let priority = "tests/idct" in
    let default = !default_suites in
    if List.mem priority default
    then priority :: (List.filter (fun name -> name <> priority) default)
    else default
  in
  let suites =
    match !suites with
    | [] -> default_suites ()
    | l ->
      List.fold_left (fun acc x ->
          if x = "tests"
          then (default_suites ()) @ acc
          else x::acc
        ) [] l
  in
  let interpret_as_file suite =
1663
1664
1665
1666
1667
    try
      let ext = Filename.chop_extension suite in
      ext <> ""
    with Invalid_argument _ -> false
  in
1668
1669
1670
1671
1672
1673
1674
1675
1676
  let exclude_suite, exclude_file =
    List.fold_left
      (fun (suite,test) x ->
         if interpret_as_file x then (suite,x::test) else (x::suite,test))
      ([],[]) !exclude_suites
  in
  List.iter
    (fun suite ->
       if !verbosity >= 2 then lock_printf "%% producer now treating test %s\n%!" suite;
1677
       (* the "suite" may be a directory or a single file *)
1678
1679
1680
1681
1682
1683
1684
1685
1686
       let interpret_as_file = interpret_as_file suite in
       let directory =
         SubDir.create (if interpret_as_file
                        then
                          Filename.dirname suite
                        else
                          suite)
       in
       let config = SubDir.make_file directory dir_config_file in
1687
1688
       let default = default_config () in
       let default = update_dir_ref directory default in
1689
1690
1691
1692
       let dir_config =
         if Sys.file_exists config
         then begin
           let scan_buffer = Scanf.Scanning.from_file config in
1693
           scan_options directory scan_buffer default
1694
         end
1695
         else default
Virgile Prevosto's avatar