Libguestfs - Nov 2017 - [PATCH REPOST 1/2] common/mlstdutils: Add return statement.

No change, just reposting without the "for discussion" tag.

I think we should allow this as it seems like a nice coding style for
a limited subset of imperative-style code.

Rich.

This adds a ‘return’ statement as found in other programming
languages.  You can use it like this:

  with_return (fun {return} ->
    some code ...
  )

where ‘some code’ may either return implicitly (as usual), or may call
‘return x’ to immediately return ‘x’.  All returned values must have
the same type.

The OCaml >= 4.04 implementation is by Petter A. Urkedal and octachron.
See this thread:
https://sympa.inria.fr/sympa/arc/caml-list/2017-11/msg00017.html

The version that works for any OCaml is by me.  (Note that my version
cannot be nested).
---
 common/mlstdutils/std_utils.ml  | 16 ++++++++++++++++
 common/mlstdutils/std_utils.mli | 14 ++++++++++++++
 2 files changed, 30 insertions(+)

diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index fd5f04db5..ba23011f7 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -598,6 +598,22 @@ let protect ~f ~finally    finally ();
   match r with Either ret -> ret | Or exn -> raise exn
 
+type 'a return = { return: 'b. 'a -> 'b } (* OCaml >=
4.03: [@@unboxed] *)
+(* This requires features in OCaml >= 4.04:
+let with_return (type a) f +  let exception Return of a in
+  try f {return = fun ret -> raise (Return ret)} with Return ret -> ret
+*)
+
+(* This should work for any version of OCaml, but it doesn't work
+ * properly for nested with_return statements.  When we can assume
+ * OCaml >= 4.04 we should use the above definition instead.
+ *)
+let with_return f +  let ret = ref None in
+  try f {return = fun r -> ret := Some r; raise Exit}
+  with Exit -> match !ret with None -> assert false | Some r -> r
+
 let failwithf fs = ksprintf failwith fs
 
 exception Executable_not_found of string (* executable *)
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index 5f74db5d6..d99347128 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -347,6 +347,20 @@ val protect : f:(unit -> 'a) -> finally:(unit
-> unit) -> 'a
     case, but requires a lot more work by the caller.  Perhaps we
     will change this in future.) *)
 
+type 'a return = { return: 'b. 'a -> 'b } (* OCaml >=
4.03: [@@unboxed] *)
+val with_return : ('a return -> 'a) -> 'a
+(** {v
+    with_return (fun {return} ->
+      some code ...
+    )
+    v}
+    emulates the [return] statement found in other programming
+    languages.
+
+    The ‘some code’ part may either return implicitly, or may call
+    [return x] to immediately return the value [x].  All returned
+    values must have the same type. *)
+
 val failwithf : ('a, unit, string, 'b) format4 -> 'a
 (** Like [failwith] but supports printf-like arguments. *)
 
-- 
2.13.2

When rewriting this, I revisited the original C code and changed the
OCaml code so it's now reasonably similar to the original.
---
 daemon/inspect_fs_unix_fstab.ml | 205 +++++++++++++++++++++-------------------
 1 file changed, 107 insertions(+), 98 deletions(-)

diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml
index 658e0cf10..371474d63 100644
--- a/daemon/inspect_fs_unix_fstab.ml
+++ b/daemon/inspect_fs_unix_fstab.ml
@@ -55,111 +55,120 @@ and check_fstab_aug mdadm_conf root_mountable os_type aug 
List.filter_map (check_fstab_entry md_map root_mountable os_type aug) entries
 
 and check_fstab_entry md_map root_mountable os_type aug entry -  if verbose ()
then
-    eprintf "check_fstab_entry: augeas path: %s\n%!" entry;
+  with_return (fun {return} ->
+    if verbose () then
+      eprintf "check_fstab_entry: augeas path: %s\n%!" entry;
 
-  let is_bsd -    match os_type with
-    | OS_TYPE_FREEBSD | OS_TYPE_NETBSD | OS_TYPE_OPENBSD -> true
-    | OS_TYPE_DOS | OS_TYPE_HURD | OS_TYPE_LINUX | OS_TYPE_MINIX
-    | OS_TYPE_WINDOWS -> false in
+    let is_bsd +      match os_type with
+      | OS_TYPE_FREEBSD | OS_TYPE_NETBSD | OS_TYPE_OPENBSD -> true
+      | OS_TYPE_DOS | OS_TYPE_HURD | OS_TYPE_LINUX | OS_TYPE_MINIX
+      | OS_TYPE_WINDOWS -> false in
 
-  let spec = aug_get_noerrors aug (entry ^ "/spec") in
-  let mp = aug_get_noerrors aug (entry ^ "/file") in
-  let vfstype = aug_get_noerrors aug (entry ^ "/vfstype") in
+    let spec = aug_get_noerrors aug (entry ^ "/spec") in
+    let spec +      match spec with
+      | None -> return None
+      | Some spec -> spec in
 
-  match spec, mp, vfstype with
-  | None, _, _ | Some _, None, _ | Some _, Some _, None -> None
-  | Some spec, Some mp, Some vfstype ->
-     if verbose () then
-       eprintf "check_fstab_entry: spec=%s mp=%s vfstype=%s\n%!"
-               spec mp vfstype;
+    if verbose () then eprintf "check_fstab_entry: spec=%s\n%!" spec;
 
-     (* Ignore /dev/fd (floppy disks) (RHBZ#642929) and CD-ROM drives.
-      *
-      * /dev/iso9660/FREEBSD_INSTALL can be found in FreeBSD's
-      * installation discs.
-      *)
-     if (String.is_prefix spec "/dev/fd" &&
-         String.length spec >= 8 && Char.isdigit spec.[7]) ||
-        (String.is_prefix spec "/dev/cd" &&
-         String.length spec >= 8 && Char.isdigit spec.[7]) ||
-        spec = "/dev/floppy" ||
-        spec = "/dev/cdrom" ||
-        String.is_prefix spec "/dev/iso9660/" then
-       None
-     else (
-       (* Canonicalize the path, so "///usr//local//" ->
"/usr/local" *)
-       let mp = unix_canonical_path mp in
+    (* Ignore /dev/fd (floppy disks) (RHBZ#642929) and CD-ROM drives.
+     *
+     * /dev/iso9660/FREEBSD_INSTALL can be found in FreeBSD's
+     * installation discs.
+     *)
+    if (String.is_prefix spec "/dev/fd" &&
+        String.length spec >= 8 && Char.isdigit spec.[7]) ||
+       (String.is_prefix spec "/dev/cd" &&
+        String.length spec >= 8 && Char.isdigit spec.[7]) ||
+       spec = "/dev/floppy" ||
+       spec = "/dev/cdrom" ||
+       String.is_prefix spec "/dev/iso9660/" then
+      return None;
 
-       (* Ignore certain mountpoints. *)
-       if String.is_prefix mp "/dev/" ||
-          mp = "/dev" ||
-          String.is_prefix mp "/media/" ||
-          String.is_prefix mp "/proc/" ||
-          mp = "/proc" ||
-          String.is_prefix mp "/selinux/" ||
-          mp = "/selinux" ||
-          String.is_prefix mp "/sys/" ||
-          mp = "/sys" then
-         None
-       else (
-         let mountable -           (* Resolve UUID= and LABEL= to the actual
device. *)
-           if String.is_prefix spec "UUID=" then (
-             let uuid = String.sub spec 5 (String.length spec - 5) in
-             let uuid = shell_unquote uuid in
-             Some (Mountable.of_device (Findfs.findfs_uuid uuid))
-           )
-           else if String.is_prefix spec "LABEL=" then (
-             let label = String.sub spec 6 (String.length spec - 6) in
-             let label = shell_unquote label in
-             Some (Mountable.of_device (Findfs.findfs_label label))
-           )
-           (* Resolve /dev/root to the current device.
-            * Do the same for the / partition of the *BSD
-            * systems, since the BSD -> Linux device
-            * translation is not straight forward.
-            *)
-           else if spec = "/dev/root" || (is_bsd && mp =
"/") then
-             Some root_mountable
-           (* Resolve guest block device names. *)
-           else if String.is_prefix spec "/dev/" then
-             Some (resolve_fstab_device spec md_map os_type)
-           (* In OpenBSD's fstab you can specify partitions
-            * on a disk by appending a period and a partition
-            * letter to a Disklable Unique Identifier. The
-            * DUID is a 16 hex digit field found in the
-            * OpenBSD's altered BSD disklabel. For more info
-            * see here:
-            * http://www.openbsd.org/faq/faq14.html#intro
-            *)
-           else if PCRE.matches re_openbsd_duid spec then (
-             let part = spec.[17] in
-             (* We cannot peep into disklabels, we can only
-              * assume that this is the first disk.
-              *)
-             let device = sprintf "/dev/sd0%c" part in
-             Some (resolve_fstab_device device md_map os_type)
-           )
-           (* Ignore "/.swap" (Pardus) and pseudo-devices
-            * like "tmpfs".  If we haven't resolved the device
-            * successfully by this point, just ignore it.
-            *)
-           else
-             None in
+    let mp = aug_get_noerrors aug (entry ^ "/file") in
+    let mp +      match mp with
+      | None -> return None
+      | Some mp -> mp in
 
-         match mountable with
-         | None -> None
-         | Some mountable ->
-            let mountable -              if vfstype = "btrfs" then
-                get_btrfs_mountable aug entry mountable
-              else mountable in
+    (* Canonicalize the path, so "///usr//local//" ->
"/usr/local" *)
+    let mp = unix_canonical_path mp in
 
-            Some (mountable, mp)
-       )
-     )
+    if verbose () then eprintf "check_fstab_entry: mp=%s\n%!" mp;
+
+    (* Ignore certain mountpoints. *)
+    if String.is_prefix mp "/dev/" ||
+       mp = "/dev" ||
+       String.is_prefix mp "/media/" ||
+       String.is_prefix mp "/proc/" ||
+       mp = "/proc" ||
+       String.is_prefix mp "/selinux/" ||
+       mp = "/selinux" ||
+       String.is_prefix mp "/sys/" ||
+       mp = "/sys" then
+      return None;
+
+    let mountable +      (* Resolve UUID= and LABEL= to the actual device. *)
+      if String.is_prefix spec "UUID=" then (
+        let uuid = String.sub spec 5 (String.length spec - 5) in
+        let uuid = shell_unquote uuid in
+        Mountable.of_device (Findfs.findfs_uuid uuid)
+      )
+      else if String.is_prefix spec "LABEL=" then (
+        let label = String.sub spec 6 (String.length spec - 6) in
+        let label = shell_unquote label in
+        Mountable.of_device (Findfs.findfs_label label)
+      )
+      (* Resolve /dev/root to the current device.
+       * Do the same for the / partition of the *BSD
+       * systems, since the BSD -> Linux device
+       * translation is not straight forward.
+       *)
+      else if spec = "/dev/root" || (is_bsd && mp =
"/") then
+        root_mountable
+      (* Resolve guest block device names. *)
+      else if String.is_prefix spec "/dev/" then
+        resolve_fstab_device spec md_map os_type
+      (* In OpenBSD's fstab you can specify partitions
+       * on a disk by appending a period and a partition
+       * letter to a Disklable Unique Identifier. The
+       * DUID is a 16 hex digit field found in the
+       * OpenBSD's altered BSD disklabel. For more info
+       * see here:
+       * http://www.openbsd.org/faq/faq14.html#intro
+       *)
+      else if PCRE.matches re_openbsd_duid spec then (
+        let part = spec.[17] in
+        (* We cannot peep into disklabels, we can only
+         * assume that this is the first disk.
+         *)
+        let device = sprintf "/dev/sd0%c" part in
+        resolve_fstab_device device md_map os_type
+      )
+      (* Ignore "/.swap" (Pardus) and pseudo-devices
+       * like "tmpfs".  If we haven't resolved the device
+       * successfully by this point, just ignore it.
+       *)
+      else
+        return None in
+
+    let vfstype = aug_get_noerrors aug (entry ^ "/vfstype") in
+    let vfstype +      match vfstype with
+      | None -> return None
+      | Some vfstype -> vfstype in
+    if verbose () then eprintf "check_fstab_entry: vfstype=%s\n%!"
vfstype;
+
+    let mountable +      if vfstype = "btrfs" then
+        get_btrfs_mountable aug entry mountable
+      else mountable in
+
+    Some (mountable, mp)
+  )
 
 (* If an fstab entry corresponds to a btrfs filesystem, look for
  * the 'subvol' option and if it is present then return a btrfs
-- 
2.13.2