Unknown-unknown behaviour for unknown utilities and failed argument p…

…arsing

src/concrete/utilities.ml

@@ -12,29 +12,29 @@ module IdMap = Env.IdMap
 
 type env = string IdMap.t
 
-let unsupported ~utility msg = fun sta ->
-  if !Options.fail_on_unknown_utilities then
-    raise (Errors.Unsupported (utility, msg))
-  else
-    let str = utility ^ ": " ^ msg in
-    let stdout = Stdout.(sta.stdout |> output str |> newline) in
-    {sta with stdout}, Ok false
+let incomplete ~utility msg = fun sta ->
+  let str = utility ^ ": " ^ msg in
+  let stdout = Stdout.(sta.stdout |> output str |> newline) in
+  {sta with stdout}, Incomplete
 
-let unknown_utility utility = fun sta ->
-  if !Options.fail_on_unknown_utilities then
-    raise (Errors.Unsupported (utility, "unknown utility"))
-  else
-    let str = utility ^ ": command not found" in
-    let stdout = Stdout.(sta.stdout |> output str |> newline) in
-    {sta with stdout}, Ok false
+let error ~utility msg = fun sta ->
+  let str = utility ^ ": " ^ msg in
+  let stdout = Stdout.(sta.stdout |> output str |> newline) in
+  {sta with stdout}, Ok false
+
+let unknown ~utility msg =
+  match !Options.unknown_behaviour with
+  | Exception -> raise (Errors.Unknown_behaviour (utility, msg))
+  | Incomplete -> incomplete ~utility msg
+  | Error -> error ~utility msg
 
 let test (sta : state) : string list -> (state * bool result) = function
   | [sa; "="; sb] ->
     (sta, Ok (sa = sb))
   | [sa; "!="; sb] ->
     (sta, Ok (sa <> sb))
-  | _ ->
-    unsupported ~utility:"test" "arguments different from . = . and . != ." sta
+  | args ->
+    unknown ~utility:"test" (String.concat " " args) sta
 
 let dpkg_compare_versions args =
   Sys.command ("dpkg --compare-versions " ^ String.concat " " args) = 0
@@ -73,7 +73,7 @@ let interp_utility (_cwd, var_env, args) id sta =
       List.map format_line |>
       List.fold_left print_line sta, Ok true
     | _arg :: _ ->
-      unsupported ~utility:"env" "no arguments supported" sta
+      incomplete ~utility:"env" "no arguments supported" sta
     end
   | "grep" -> (* Just for testing stdin/stdout handling *)
      begin match args with
@@ -92,26 +92,27 @@ let interp_utility (_cwd, var_env, args) id sta =
         let sta' = {sta with stdout; stdin=Stdin.empty} in
         sta', Ok result
      | [] ->
-       unsupported ~utility:"grep" "missing argument" sta
+       error ~utility:"grep" "missing argument" sta
      | _arg :: _ ->
-       unsupported ~utility:"grep" "two or more arguments" sta
+       incomplete ~utility:"grep" "two or more arguments" sta
      end
   | "dpkg" ->
      begin match args with
      | (("--validate-pkgname" | "--validate-trigname" |
          "--validate-archname" | "--validate-version") as subcmd)::args->
         if List.length args = 1
         then sta, Ok (dpkg_validate_thing subcmd (List.hd args))
-        else unsupported ~utility:"dpkg"
+        else error ~utility:"dpkg"
                "--validate_thing needs excactly 1 argument" sta
      | "--compare-versions"::args ->
       if List.length args = 3
       then sta, Ok (dpkg_compare_versions args)
-      else unsupported ~utility:"dpkg"
+      else error ~utility:"dpkg"
              "--compare-versions needs excatly 3 arguments" sta
-     | _ -> unsupported ~utility:"dpkg" "unsupported arguments" sta
+     | _ -> error ~utility:"dpkg" "unsupported arguments" sta
      end
-  | _ -> unknown_utility id sta
+  | _ ->
+    unknown ~utility:id "unknown" sta
 
 let absolute_or_concat_relative (p: string list) (s: string) : string list =
   if String.equal s "" then

src/symbolic/symbolicUtility.ml

@@ -91,27 +91,23 @@ let print_stdout ~newline str sta =
   let log = print_output ~newline str sta.log in
   {sta with stdout; log}
 
-let print_error opt sta =
-  match opt with
-  | None -> sta
-  | Some str ->
-    let log = print_output ~newline:true ("[ERROR] "^str) sta.log in
-    {sta with log}
+let print_error str sta =
+  let log = print_output ~newline:true ("[ERROR] "^str) sta.log in
+  {sta with log}
 
-let print_incomplete_trace str sta =
+let print_utility_trace str sta =
   if String.equal str "" then
     sta
   else
     let log =
-      print_output ~newline:true ("[INCOMPLETE] "^str) sta.log in
+      print_output ~newline:true ("[TRACE] "^str) sta.log in
     {sta with log}
 
-let print_utility_trace str sta =
+let print_incomplete_trace str sta =
   if String.equal str "" then
     sta
   else
-    let log =
-      print_output ~newline:true ("[TRACE] "^str) sta.log in
+    let log = print_output ~newline:true ("[INCOMPLETE] "^str) sta.log in
     {sta with log}
 
 type case_spec = Var.t -> Var.t -> Clause.t
@@ -167,8 +163,9 @@ let apply_spec fs spec =
 let apply_case sta case : (state * bool result) list =
   (* First print the utility trace *)
   let sta =
-    let print = match case.result with Ok _ -> print_utility_trace | Incomplete -> print_incomplete_trace in
-    print case.descr sta in
+    if case.result = Incomplete
+    then sta (* Print incomplete trace last *)
+    else print_utility_trace case.descr sta in
   let sta = {
     (* output case stdout to stdout and log *)
     stdout = Stdout.concat sta.stdout case.stdout;
@@ -179,10 +176,14 @@ let apply_case sta case : (state * bool result) list =
     filesystem = sta.filesystem;
   } in
   (* (Optionally) print error message *)
-  if case.result = Incomplete then
-    (* Make sure that the description is the last message on the log *)
-    assert (case.error_message = None);
-  let sta = print_error case.error_message sta in
+  let sta =
+    match case.error_message with
+    | Some msg -> print_error msg sta
+    | None -> sta in
+  let sta =
+    if case.result = Incomplete
+    then print_incomplete_trace case.descr sta
+    else sta in
   (* Apply the case specifications to the filesystem *)
   apply_spec sta.filesystem case.spec |>
   (* Inject the resulting filesystems into the state *)
@@ -208,21 +209,22 @@ let last_comp_as_hint: root:Var.t -> Path.t -> string option =
        (* We can’t know (if last component in parent path is a symbolic link) *)
       None
 
-let error ?msg () : utility =
+let error ~utility msg : utility =
   fun sta ->
-    let sta' = print_error msg sta in
+    let str = utility ^ ": " ^ msg in
+    let sta' = print_error str sta in
     [ sta', Ok false ]
 
-let incomplete ~descr () : utility =
+let incomplete ~utility msg : utility =
   fun sta ->
-    let sta' = print_incomplete_trace descr sta in
-    [sta', Incomplete]
+    let str = utility ^ ": " ^ msg in
+    [print_incomplete_trace str sta, Incomplete]
 
-let unsupported ~utility msg =
-  if !Options.fail_on_unknown_utilities then
-    Errors.unsupported ~utility msg
-  else
-    incomplete ~descr:(utility ^ ": " ^ msg) ()
+let unknown ~utility msg : utility =
+  match !Options.unknown_behaviour with
+  | Exception -> raise (Errors.Unknown_behaviour (utility, msg))
+  | Incomplete -> incomplete ~utility msg
+  | Error -> error ~utility "not found"
 
 module IdMap = Env.IdMap
 
@@ -249,8 +251,8 @@ let is_registered = Hashtbl.mem table
 
 let dispatch ~name =
   try Hashtbl.find table name
-  with Not_found -> fun _ ->
-    error ~msg:(name^": command not found") ()
+  with Not_found ->
+    fun _ctx -> unknown ~utility:name "unknown"
 
 let call name ctx args =
   dispatch ~name {ctx with args}
@@ -293,7 +295,7 @@ let cmdliner_eval_utility ~utility ?(empty_pos_args=false) fun_and_args ctx =
   in
   match result with
   | `Ok a -> a
-  | `Version -> Errors.unsupported ~utility "version"
-  | `Help -> Errors.unsupported ~utility "help"
-  | `Error (`Parse | `Term) -> Errors.unsupported ~utility ("parse error: " ^ err)
+  | `Version -> error ~utility "version"
+  | `Help -> error ~utility "help"
+  | `Error (`Parse | `Term) -> unknown ~utility ("parse error: " ^ err)
   | `Error `Exn -> assert false (* because ~catch:false *)

src/symbolic/symbolicUtility.mli

@@ -109,20 +109,20 @@ val compose_strict : utility -> utility -> utility
 
 (** {1 Auxiliaries} *)
 
-(** Error utility with optional message *)
-val error : ?msg:string -> unit -> utility
+(** Error utility *)
+val error : utility:string -> string -> utility
 
 (** Unsupported stuff in a known utility. *)
-val unsupported : utility:string -> string -> utility
+val incomplete : utility:string -> string -> utility
+
+(* Unknown-unknown behaviour *)
+val unknown : utility:string -> string -> utility
 
 (** {2 Printing} *)
 
 (** Print to stdout and log *)
 val print_stdout : newline:bool -> string -> state -> state
 
-(** (Optionally) print message as error to log (marked as [ERR]) *)
-val print_error : string option -> state -> state
-
 (** Print message as utility trace to log if it is not empty (marked as [UTL]) *)
 val print_utility_trace : string -> state -> state
 

src/symbolic/utilities/cp.ml

@@ -223,15 +223,15 @@ let interprete ctx : utility =
           args_rev := arg :: !args_rev)
     ctx.args;
   if !i then
-    error ~msg:"cp: option `-i` forbidden" ()
+    error ~utility:"cp" "option `-i` forbidden"
   else
     match !e with
-    | Some arg -> unsupported ~utility:"cp" ("unknown argument: " ^ arg)
+    | Some arg -> error ~utility:"cp" ("unknown argument: " ^ arg)
     | None -> (
       let args = List.rev !args_rev in
       match args with
-      | [] -> error ~msg:"cp: missing operand" ()
-      | [_arg] -> error ~msg:"cp: not enough arguments" ()
+      | [] -> error ~utility:"cp" "missing operand"
+      | [_arg] -> error ~utility:"cp" "not enough arguments"
       | [src; dst] -> (* 2 arguments: first, second and third synopsis forms *)
           interp_cp2 ctx ~todir:false ~isrec:!r src dst
       | src::_ -> (* second and third synopsis forms, cp in existing directory *)

src/symbolic/utilities/dpkg.ml

@@ -18,18 +18,18 @@ let interprete ctx =
             [sta, Ok true]
         )
       else
-        unsupported ~utility "-L about an other package"
+        incomplete ~utility "-L about an other package"
 
     | "-L" :: _ ->
-      unsupported ~utility "option -L expects exactly one argument"
+      error ~utility "option -L expects exactly one argument"
     | ["--compare-versions"; _v1; _v2] ->
-      unsupported ~utility "support for --compare-versions not yet implemented"
+      incomplete ~utility "support for --compare-versions not yet implemented"
     | "--compare-versions" :: _ ->
-      unsupported ~utility "option --compare-versions expects exactly two arguments"
+      error ~utility "option --compare-versions expects exactly two arguments"
     | [] ->
       (* TODO: return error state *)
-      unsupported ~utility "no argument found"
+      error ~utility "no argument found"
     | arg :: _ ->
-      unsupported ~utility ("unsupported argument: " ^ arg)
+      incomplete ~utility ("unsupported argument: " ^ arg)
   in
   aux ctx.args