mllib: Getopt: add Getopt.Symbol

Introduce a new type of option to allow a value out of a fixed choice,
much like Arg.Symbol.

mllib/getopt-c.c

@@ -103,6 +103,69 @@ find_spec (value specsv, int specs_len, char opt)
   CAMLreturnT (int, ret);
 }
 
+static bool
+list_mem (value listv, const char *val)
+{
+  CAMLparam1 (listv);
+  CAMLlocal1 (hd);
+  bool found = false;
+
+  while (listv != Val_emptylist) {
+    hd = Field (listv, 0);
+    if (STREQ (String_val (hd), val)) {
+      found = true;
+      break;
+    }
+    listv = Field (listv, 1);
+  }
+
+  CAMLreturnT (bool, found);
+}
+
+static bool
+vector_has_dashdash_opt (value vectorv, const char *opt)
+{
+  CAMLparam1 (vectorv);
+  bool found = false;
+  int len, i;
+
+  len = Wosize_val (vectorv);
+
+  for (i = 0; i < len; ++i) {
+    const char *key = String_val (Field (vectorv, i));
+
+    ++key;
+    if (key[0] == '-')
+      ++key;
+
+    if (STREQ (opt, key)) {
+      found = true;
+      break;
+    }
+  }
+
+  CAMLreturnT (bool, found);
+}
+
+static void
+list_print (FILE *stream, value listv)
+{
+  CAMLparam1 (listv);
+  CAMLlocal1 (hd);
+  bool first = true;
+
+  while (listv != Val_emptylist) {
+    hd = Field (listv, 0);
+    if (!first)
+      fprintf (stream, ", ");
+    fprintf (stream, "%s", String_val (hd));
+    first = false;
+    listv = Field (listv, 1);
+  }
+
+  CAMLreturn0;
+}
+
 static void
 do_call1 (value funv, value paramv)
 {
@@ -206,6 +269,7 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv, value anon_funv, valu
       case 4:  /* Set_string of string * string ref */
       case 5:  /* Int of string * (int -> unit) */
       case 6:  /* Set_int of string * int ref */
+      case 7:  /* Symbol of string * string list * (string -> unit) */
         has_arg = 1;
         break;
 
@@ -306,6 +370,28 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv, value anon_funv, valu
       caml_modify (&Field (Field (actionv, 1), 0), Val_int (num));
       break;
 
+    case 7:  /* Symbol of string * string list * (string -> unit) */
+      v = Field (actionv, 1);
+      if (!list_mem (v, optarg)) {
+        if (c != 0) {
+          fprintf (stderr, _("%s: '%s' is not allowed for -%c; allowed values are:\n"),
+                   guestfs_int_program_name, optarg, c);
+        } else {
+          fprintf (stderr, _("%s: '%s' is not allowed for %s%s; allowed values are:\n"),
+                   guestfs_int_program_name, optarg,
+                   vector_has_dashdash_opt (specv, longopts[option_index].name) ? "--" : "-",
+                   longopts[option_index].name);
+        }
+        fprintf (stderr, "  ");
+        list_print (stderr, v);
+        fprintf (stderr, "\n");
+        show_error (EXIT_FAILURE);
+      }
+      v = Field (actionv, 2);
+      v2 = caml_copy_string (optarg);
+      do_call1 (v, v2);
+      break;
+
     default:
       error (EXIT_FAILURE, 0,
              "internal error: unhandled Tag_val (actionv) = %d",

mllib/getopt.ml

@@ -28,6 +28,7 @@ type spec =
   | Set_string of string * string ref
   | Int of string * (int -> unit)
   | Set_int of string * int ref
+  | Symbol of string * string list * (string -> unit)
 
 module OptionName = struct
   type option_name = S of char | L of string | M of string
@@ -93,7 +94,8 @@ let show_help h () =
         | String (arg, _)
         | Set_string (arg, _)
         | Int (arg, _)
-        | Set_int (arg, _) -> Some arg in
+        | Set_int (arg, _)
+        | Symbol (arg, _, _) -> Some arg in
       (match arg with
       | None -> ()
       | Some arg ->
@@ -168,11 +170,29 @@ let create specs ?anon_fun usage_msg =
                             s)
     | _ -> ()
   in
+
+  let validate_spec = function
+    | Unit _ -> ()
+    | Set _ -> ()
+    | Clear _ -> ()
+    | String _ -> ()
+    | Set_string _ -> ()
+    | Int _ -> ()
+    | Set_int _ -> ()
+    | Symbol (_, elements, _) ->
+      List.iter (
+        fun e ->
+          if String.length e == 0 || is_prefix e "-" then
+            invalid_arg (sprintf "invalid element in Symbol: '%s'" e);
+      ) elements;
+  in
+
   List.iter (
     fun (keys, spec, doc) ->
       if keys == [] then
         invalid_arg "empty keys for Getopt spec";
-      List.iter validate_key keys
+      List.iter validate_key keys;
+      validate_spec spec;
   ) specs;
 
   let t = {

mllib/getopt.mli

@@ -39,6 +39,11 @@ type spec =
     (** Option requiring an integer value as argument; the first
         element in the tuple is the documentation string of the
         argument, and the second is the reference to be set. *)
+  | Symbol of string * string list * (string -> unit)
+    (** Option requiring an argument among a fixed set; the first
+        element in the tuple is the documentation string of the
+        argument, the second is the list of allowed strings,
+        and the third is the function to call. *)
 
 module OptionName : sig
   type option_name =

sysprep/sysprep_operation.ml

@@ -224,7 +224,7 @@ let dump_pod_options () =
     | (op_name,
        { extra_argspec = (arg_names,
                           (Getopt.String _ | Getopt.Set_string _ | Getopt.Int _ |
-                           Getopt.Set_int _),
+                           Getopt.Set_int _ | Getopt.Symbol _),
                           _);
          extra_pod_argval = Some arg_val;
          extra_pod_description = pod }) ->