Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 0/5] daemon: generate almall the API OCaml interfaces
Hi,
as a followup for the signature fix for mount_vfs [1], here it is a
patch series to generate automatically all the OCaml interfaces of
daemon actions.
[1] https://www.redhat.com/archives/libguestfs/2018-April/msg00059.html
Thanks,
Pino Toscano (5):
daemon: directly use Optgroups
daemon: use the structs from the Structs module
daemon: move Lvm.lv_canonical to new Lvm_utils module
daemon: move Mount.umount_all to new Mount_utils module
daemon: autogenerate OCaml interfaces
.gitignore | 17 ++++++++
daemon/Makefile.am | 4 ++
daemon/blkid.mli | 19 ---------
daemon/btrfs.mli | 26 -----------
daemon/devsparts.mli | 25 -----------
daemon/filearch.mli | 19 ---------
daemon/findfs.ml | 2 +-
daemon/findfs.mli | 20 ---------
daemon/inspect.ml | 2 +-
daemon/inspect.mli | 41 ------------------
daemon/inspect_fs.ml | 2 +-
daemon/inspect_fs_unix_fstab.ml | 2 +-
daemon/inspect_fs_windows.ml | 4 +-
daemon/is.mli | 21 ---------
daemon/ldm.ml | 2 -
daemon/ldm.mli | 22 ----------
daemon/link.mli | 19 ---------
daemon/listfs.ml | 8 ++--
daemon/listfs.mli | 19 ---------
daemon/lvm.ml | 29 -------------
daemon/lvm_utils.ml | 48 +++++++++++++++++++++
daemon/{lvm.mli => lvm_utils.mli} | 4 --
daemon/md.mli | 20 ---------
daemon/mount.ml | 61 --------------------------
daemon/mount.mli | 24 -----------
daemon/mount_utils.ml | 83 ++++++++++++++++++++++++++++++++++++
daemon/{file.mli => mount_utils.mli} | 2 +-
daemon/parted.mli | 34 ---------------
daemon/realpath.mli | 20 ---------
daemon/statvfs.mli | 33 --------------
generator/daemon.ml | 83 ++++++++++++++++++++++++++++++++++++
generator/daemon.mli | 1 +
generator/main.ml | 17 ++++++++
33 files changed, 264 insertions(+), 469 deletions(-)
delete mode 100644 daemon/blkid.mli
delete mode 100644 daemon/btrfs.mli
delete mode 100644 daemon/devsparts.mli
delete mode 100644 daemon/filearch.mli
delete mode 100644 daemon/findfs.mli
delete mode 100644 daemon/inspect.mli
delete mode 100644 daemon/is.mli
delete mode 100644 daemon/ldm.mli
delete mode 100644 daemon/link.mli
delete mode 100644 daemon/listfs.mli
create mode 100644 daemon/lvm_utils.ml
rename daemon/{lvm.mli => lvm_utils.mli} (94%)
delete mode 100644 daemon/md.mli
delete mode 100644 daemon/mount.mli
create mode 100644 daemon/mount_utils.ml
rename daemon/{file.mli => mount_utils.mli} (96%)
delete mode 100644 daemon/parted.mli
delete mode 100644 daemon/realpath.mli
delete mode 100644 daemon/statvfs.mli
--
2.14.3
Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 1/5] daemon: directly use Optgroups
Avoid extra module variables, and just use Optgroups directly. --- daemon/ldm.ml | 2 -- daemon/ldm.mli | 2 -- daemon/listfs.ml | 4 ++-- daemon/lvm.ml | 2 -- daemon/lvm.mli | 2 -- 5 files changed, 2 insertions(+), 10 deletions(-) diff --git a/daemon/ldm.ml b/daemon/ldm.ml index c17766600..b48b0f4eb 100644 --- a/daemon/ldm.ml +++ b/daemon/ldm.ml @@ -20,8 +20,6 @@ open Std_utils open Utils -let available = Optgroups.ldm_available - (* All device mapper devices are called /dev/mapper/ldm_vol_* * or /dev/mapper/ldm_part_*. * diff --git a/daemon/ldm.mli b/daemon/ldm.mli index a45948910..74afdf5d8 100644 --- a/daemon/ldm.mli +++ b/daemon/ldm.mli @@ -16,7 +16,5 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -val available : unit -> bool - val list_ldm_volumes : unit -> string list val list_ldm_partitions : unit -> string list diff --git a/daemon/listfs.ml b/daemon/listfs.ml index 370ffb4f4..f6e3dcd6e 100644 --- a/daemon/listfs.ml +++ b/daemon/listfs.ml @@ -21,8 +21,8 @@ open Printf open Std_utils let rec list_filesystems () - let has_lvm2 = Lvm.available () in - let has_ldm = Ldm.available () in + let has_lvm2 = Optgroups.lvm2_available () in + let has_ldm = Optgroups.ldm_available () in let devices = Devsparts.list_devices () in let partitions = Devsparts.list_partitions () in diff --git a/daemon/lvm.ml b/daemon/lvm.ml index 467495f7e..ed4ed7462 100644 --- a/daemon/lvm.ml +++ b/daemon/lvm.ml @@ -23,8 +23,6 @@ open Std_utils open Utils -let available = Optgroups.lvm2_available - (* Check whether lvs has -S to filter its output. * It is available only in lvm2 >= 2.02.107. *) diff --git a/daemon/lvm.mli b/daemon/lvm.mli index 94a35d83c..e9a6faeca 100644 --- a/daemon/lvm.mli +++ b/daemon/lvm.mli @@ -16,8 +16,6 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -val available : unit -> bool - val lvs : unit -> string list val lv_canonical : string -> string option -- 2.14.3
Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 2/5] daemon: use the structs from the Structs module
No need to redeclare them again in few modules, just use them from the
Structs module.
---
daemon/btrfs.mli | 8 +-------
daemon/inspect_fs_windows.ml | 4 ++--
daemon/listfs.ml | 4 ++--
daemon/parted.mli | 9 +--------
daemon/statvfs.mli | 16 +---------------
5 files changed, 7 insertions(+), 34 deletions(-)
diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli
index 8ca91fb47..ce1c2b66f 100644
--- a/daemon/btrfs.mli
+++ b/daemon/btrfs.mli
@@ -16,11 +16,5 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-type btrfssubvolume = {
- btrfssubvolume_id : int64;
- btrfssubvolume_top_level_id : int64;
- btrfssubvolume_path : string;
-}
-
-val btrfs_subvolume_list : Mountable.t -> btrfssubvolume list
+val btrfs_subvolume_list : Mountable.t -> Structs.btrfssubvolume list
val btrfs_subvolume_get_default : Mountable.t -> int64
diff --git a/daemon/inspect_fs_windows.ml b/daemon/inspect_fs_windows.ml
index e9d056cd9..8b2aad8d3 100644
--- a/daemon/inspect_fs_windows.ml
+++ b/daemon/inspect_fs_windows.ml
@@ -372,10 +372,10 @@ and map_registry_disk_blob devices blob let offset =
int_of_le64 offset in
let partitions = Parted.part_list device in
let partition - List.find (fun { Parted.part_start = s } -> s =
offset) partitions in
+ List.find (fun { Structs.part_start = s } -> s = offset) partitions in
(* Construct the full device name. *)
- Some (sprintf "%s%ld" device partition.Parted.part_num)
+ Some (sprintf "%s%ld" device partition.Structs.part_num)
with
| Not_found -> None
diff --git a/daemon/listfs.ml b/daemon/listfs.ml
index f6e3dcd6e..56ebadeda 100644
--- a/daemon/listfs.ml
+++ b/daemon/listfs.ml
@@ -125,13 +125,13 @@ and check_with_vfs_type device let default_volume =
Btrfs.btrfs_subvolume_get_default mountable in
let vols List.filter (
- fun { Btrfs.btrfssubvolume_id = id } -> id <> default_volume
+ fun { Structs.btrfssubvolume_id = id } -> id <> default_volume
) vols in
Some (
(mountable, vfs_type) (* whole device = default volume *)
:: List.map (
- fun { Btrfs.btrfssubvolume_path = path } ->
+ fun { Structs.btrfssubvolume_path = path } ->
let mountable = Mountable.of_btrfsvol device path in
(mountable, "btrfs")
) vols
diff --git a/daemon/parted.mli b/daemon/parted.mli
index d547f2f2a..0b7eb87f4 100644
--- a/daemon/parted.mli
+++ b/daemon/parted.mli
@@ -16,15 +16,8 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-type partition = {
- part_num : int32;
- part_start : int64;
- part_end : int64;
- part_size : int64;
-}
-
val part_get_mbr_id : string -> int -> int
-val part_list : string -> partition list
+val part_list : string -> Structs.partition list
val part_get_parttype : string -> string
diff --git a/daemon/statvfs.mli b/daemon/statvfs.mli
index d241f995b..13b22f88d 100644
--- a/daemon/statvfs.mli
+++ b/daemon/statvfs.mli
@@ -16,18 +16,4 @@
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
-type statvfs = {
- bsize : int64;
- frsize : int64;
- blocks : int64;
- bfree : int64;
- bavail : int64;
- files : int64;
- ffree : int64;
- favail : int64;
- fsid : int64;
- flag : int64;
- namemax : int64;
-}
-
-val statvfs : string -> statvfs
+val statvfs : string -> Structs.statvfs
--
2.14.3
Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 3/5] daemon: move Lvm.lv_canonical to new Lvm_utils module
This way the Lvm module contains only the OCaml implementations of LVM
daemon APIs.
This is simple refactoring, with no functional changes.
---
daemon/Makefile.am | 2 ++
daemon/findfs.ml | 2 +-
daemon/inspect_fs_unix_fstab.ml | 2 +-
daemon/lvm.ml | 27 -----------------------
daemon/lvm.mli | 10 ---------
daemon/lvm_utils.ml | 48 +++++++++++++++++++++++++++++++++++++++++
daemon/lvm_utils.mli | 27 +++++++++++++++++++++++
7 files changed, 79 insertions(+), 39 deletions(-)
create mode 100644 daemon/lvm_utils.ml
create mode 100644 daemon/lvm_utils.mli
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 9dbd375f5..9cd34ff75 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -268,6 +268,7 @@ SOURCES_MLI = \
link.mli \
listfs.mli \
lvm.mli \
+ lvm_utils.mli \
md.mli \
mount.mli \
mountable.mli \
@@ -296,6 +297,7 @@ SOURCES_ML = \
ldm.ml \
link.ml \
lvm.ml \
+ lvm_utils.ml \
findfs.ml \
md.ml \
mount.ml \
diff --git a/daemon/findfs.ml b/daemon/findfs.ml
index f613015f0..c24a194e3 100644
--- a/daemon/findfs.ml
+++ b/daemon/findfs.ml
@@ -44,7 +44,7 @@ and findfs tag str
if String.is_prefix out "/dev/mapper/" ||
String.is_prefix out "/dev/dm-" then (
- match Lvm.lv_canonical out with
+ match Lvm_utils.lv_canonical out with
| None ->
(* Ignore the case where 'out' doesn't appear to be an LV.
* The best we can do is return the original as-is.
diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml
index 43cec2323..edb797e3f 100644
--- a/daemon/inspect_fs_unix_fstab.ml
+++ b/daemon/inspect_fs_unix_fstab.ml
@@ -327,7 +327,7 @@ and resolve_fstab_device spec md_map os_type * we have
implemented lvm_canonical_lv_name in the daemon.
*)
try
- match Lvm.lv_canonical spec with
+ match Lvm_utils.lv_canonical spec with
| None -> Mountable.of_device spec
| Some device -> Mountable.of_device device
with
diff --git a/daemon/lvm.ml b/daemon/lvm.ml
index ed4ed7462..ef45ed4bc 100644
--- a/daemon/lvm.ml
+++ b/daemon/lvm.ml
@@ -97,30 +97,3 @@ and filter_convert_old_lvs_output out ) lines in
List.sort compare lines
-
-(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
- * to a canonical one.
- *
- * This is harder than it should be. A LV device like /dev/VG/LV is
- * really a symlink to a device-mapper device like /dev/dm-0. However
- * at the device-mapper (kernel) level, nothing is really known about
- * LVM (a userspace concept). Therefore we use a convoluted method to
- * determine this, by listing out known LVs and checking whether the
- * rdev (major/minor) of the device we are passed matches any of them.
- *
- * Note use of 'stat' instead of 'lstat' so that symlinks are
fully
- * resolved.
- *)
-let lv_canonical device - let stat1 = stat device in
- let lvs = lvs () in
- try
- Some (
- List.find (
- fun lv ->
- let stat2 = stat lv in
- stat1.st_rdev = stat2.st_rdev
- ) lvs
- )
- with
- | Not_found -> None
diff --git a/daemon/lvm.mli b/daemon/lvm.mli
index e9a6faeca..592168433 100644
--- a/daemon/lvm.mli
+++ b/daemon/lvm.mli
@@ -17,13 +17,3 @@
*)
val lvs : unit -> string list
-
-val lv_canonical : string -> string option
-(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
- to a canonical one.
-
- On error this raises an exception. There are two possible non-error
- return cases:
-
- Some lv = conversion was successful, returning the canonical LV
- None = input path was not an LV, it could not be made canonical *)
diff --git a/daemon/lvm_utils.ml b/daemon/lvm_utils.ml
new file mode 100644
index 000000000..a891193df
--- /dev/null
+++ b/daemon/lvm_utils.ml
@@ -0,0 +1,48 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2018 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Unix
+
+open Utils
+
+(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
+ * to a canonical one.
+ *
+ * This is harder than it should be. A LV device like /dev/VG/LV is
+ * really a symlink to a device-mapper device like /dev/dm-0. However
+ * at the device-mapper (kernel) level, nothing is really known about
+ * LVM (a userspace concept). Therefore we use a convoluted method to
+ * determine this, by listing out known LVs and checking whether the
+ * rdev (major/minor) of the device we are passed matches any of them.
+ *
+ * Note use of 'stat' instead of 'lstat' so that symlinks are
fully
+ * resolved.
+ *)
+let lv_canonical device + let stat1 = stat device in
+ let lvs = Lvm.lvs () in
+ try
+ Some (
+ List.find (
+ fun lv ->
+ let stat2 = stat lv in
+ stat1.st_rdev = stat2.st_rdev
+ ) lvs
+ )
+ with
+ | Not_found -> None
diff --git a/daemon/lvm_utils.mli b/daemon/lvm_utils.mli
new file mode 100644
index 000000000..b25a9a706
--- /dev/null
+++ b/daemon/lvm_utils.mli
@@ -0,0 +1,27 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2018 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val lv_canonical : string -> string option
+(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0
+ to a canonical one.
+
+ On error this raises an exception. There are two possible non-error
+ return cases:
+
+ Some lv = conversion was successful, returning the canonical LV
+ None = input path was not an LV, it could not be made canonical *)
--
2.14.3
Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 4/5] daemon: move Mount.umount_all to new Mount_utils module
This way the Mount module contains only the OCaml implementations of
mount-related daemon APIs.
This is simple refactoring, with no functional changes.
---
daemon/Makefile.am | 2 ++
daemon/inspect.ml | 2 +-
daemon/inspect_fs.ml | 2 +-
daemon/mount.ml | 61 -------------------------------------
daemon/mount.mli | 2 --
daemon/mount_utils.ml | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++
daemon/mount_utils.mli | 19 ++++++++++++
7 files changed, 106 insertions(+), 65 deletions(-)
create mode 100644 daemon/mount_utils.ml
create mode 100644 daemon/mount_utils.mli
diff --git a/daemon/Makefile.am b/daemon/Makefile.am
index 9cd34ff75..31eec4d33 100644
--- a/daemon/Makefile.am
+++ b/daemon/Makefile.am
@@ -271,6 +271,7 @@ SOURCES_MLI = \
lvm_utils.mli \
md.mli \
mount.mli \
+ mount_utils.mli \
mountable.mli \
optgroups.mli \
parted.mli \
@@ -301,6 +302,7 @@ SOURCES_ML = \
findfs.ml \
md.ml \
mount.ml \
+ mount_utils.ml \
parted.ml \
listfs.ml \
realpath.ml \
diff --git a/daemon/inspect.ml b/daemon/inspect.ml
index 6d4b17815..ce62c17f2 100644
--- a/daemon/inspect.ml
+++ b/daemon/inspect.ml
@@ -27,7 +27,7 @@ open Inspect_types
let re_primary_partition = PCRE.compile "^/dev/(?:h|s|v)d.[1234]$"
let rec inspect_os () - Mount.umount_all ();
+ Mount_utils.umount_all ();
(* Iterate over all detected filesystems. Inspect each one in turn. *)
let fses = Listfs.list_filesystems () in
diff --git a/daemon/inspect_fs.ml b/daemon/inspect_fs.ml
index 02e2060b9..da98946af 100644
--- a/daemon/inspect_fs.ml
+++ b/daemon/inspect_fs.ml
@@ -55,7 +55,7 @@ let rec check_for_filesystem_on mountable vfs_type if
not mounted then None
else (
let role = check_filesystem mountable in
- Mount.umount_all ();
+ Mount_utils.umount_all ();
role
)
) in
diff --git a/daemon/mount.ml b/daemon/mount.ml
index e42ea1580..4fe85d3b6 100644
--- a/daemon/mount.ml
+++ b/daemon/mount.ml
@@ -60,64 +60,3 @@ let mount_vfs options vfs mountable mountpoint let mount =
mount_vfs "" ""
let mount_ro = mount_vfs "ro" ""
let mount_options options = mount_vfs options ""
-
-(* Unmount everything mounted under /sysroot.
- *
- * We have to unmount in the correct order, so we sort the paths by
- * longest first to ensure that child paths are unmounted by parent
- * paths.
- *
- * This call is more important than it appears at first, because it
- * is widely used by both test and production code in order to
- * get back to a known state (nothing mounted, everything synchronized).
- *)
-let rec umount_all () - (* This is called from internal_autosync and generally
as a cleanup
- * function, and since the umount will definitely fail if any
- * handles are open, we may as well close them.
- *)
- (* XXX
- aug_finalize ();
- hivex_finalize ();
- journal_finalize ();
- *)
-
- let sysroot = Sysroot.sysroot () in
- let sysroot_len = String.length sysroot in
-
- let info = read_whole_file "/proc/self/mountinfo" in
- let info = String.nsplit "\n" info in
-
- let mps = ref [] in
- List.iter (
- fun line ->
- let line = String.nsplit " " line in
- (* The field of interest is the 5th field. Whitespace is escaped
- * with octal sequences like \040 (for space).
- * See fs/seq_file.c:mangle_path.
- *)
- if List.length line >= 5 then (
- let mp = List.nth line 4 in
- let mp = proc_unmangle_path mp in
-
- (* Allow a mount directory like "/sysroot" or
"/sysroot/..." *)
- if (sysroot_len > 0 && String.is_prefix mp sysroot) ||
- (String.is_prefix mp sysroot &&
- String.length mp > sysroot_len &&
- mp.[sysroot_len] = '/') then
- List.push_front mp mps
- )
- ) info;
-
- let mps = !mps in
- let mps = List.sort compare_longest_first mps in
-
- (* Unmount them. *)
- List.iter (
- fun mp -> ignore (command "umount" [mp])
- ) mps
-
-and compare_longest_first s1 s2 - let n1 = String.length s1 in
- let n2 = String.length s2 in
- n2 - n1
diff --git a/daemon/mount.mli b/daemon/mount.mli
index 96c400190..9fa5b76e7 100644
--- a/daemon/mount.mli
+++ b/daemon/mount.mli
@@ -20,5 +20,3 @@ val mount : Mountable.t -> string -> unit
val mount_ro : Mountable.t -> string -> unit
val mount_options : string -> Mountable.t -> string -> unit
val mount_vfs : string -> string -> Mountable.t -> string -> unit
-
-val umount_all : unit -> unit
diff --git a/daemon/mount_utils.ml b/daemon/mount_utils.ml
new file mode 100644
index 000000000..a53959de3
--- /dev/null
+++ b/daemon/mount_utils.ml
@@ -0,0 +1,83 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2018 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Std_utils
+
+open Mountable
+open Utils
+
+(* Unmount everything mounted under /sysroot.
+ *
+ * We have to unmount in the correct order, so we sort the paths by
+ * longest first to ensure that child paths are unmounted by parent
+ * paths.
+ *
+ * This call is more important than it appears at first, because it
+ * is widely used by both test and production code in order to
+ * get back to a known state (nothing mounted, everything synchronized).
+ *)
+let rec umount_all () + (* This is called from internal_autosync and generally
as a cleanup
+ * function, and since the umount will definitely fail if any
+ * handles are open, we may as well close them.
+ *)
+ (* XXX
+ aug_finalize ();
+ hivex_finalize ();
+ journal_finalize ();
+ *)
+
+ let sysroot = Sysroot.sysroot () in
+ let sysroot_len = String.length sysroot in
+
+ let info = read_whole_file "/proc/self/mountinfo" in
+ let info = String.nsplit "\n" info in
+
+ let mps = ref [] in
+ List.iter (
+ fun line ->
+ let line = String.nsplit " " line in
+ (* The field of interest is the 5th field. Whitespace is escaped
+ * with octal sequences like \040 (for space).
+ * See fs/seq_file.c:mangle_path.
+ *)
+ if List.length line >= 5 then (
+ let mp = List.nth line 4 in
+ let mp = proc_unmangle_path mp in
+
+ (* Allow a mount directory like "/sysroot" or
"/sysroot/..." *)
+ if (sysroot_len > 0 && String.is_prefix mp sysroot) ||
+ (String.is_prefix mp sysroot &&
+ String.length mp > sysroot_len &&
+ mp.[sysroot_len] = '/') then
+ List.push_front mp mps
+ )
+ ) info;
+
+ let mps = !mps in
+ let mps = List.sort compare_longest_first mps in
+
+ (* Unmount them. *)
+ List.iter (
+ fun mp -> ignore (command "umount" [mp])
+ ) mps
+
+and compare_longest_first s1 s2 + let n1 = String.length s1 in
+ let n2 = String.length s2 in
+ n2 - n1
diff --git a/daemon/mount_utils.mli b/daemon/mount_utils.mli
new file mode 100644
index 000000000..72421adfa
--- /dev/null
+++ b/daemon/mount_utils.mli
@@ -0,0 +1,19 @@
+(* guestfs-inspection
+ * Copyright (C) 2009-2018 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+val umount_all : unit -> unit
--
2.14.3
Pino Toscano
2018-Apr-10 10:42 UTC
[Libguestfs] [PATCH v2 5/5] daemon: autogenerate OCaml interfaces
Add a way to generate OCaml interfaces for all the modules in the
daemon that implement APIs: this makes sure that for them the
interface of each function matches the actual API specified in the
generator.
---
.gitignore | 17 +++++++++++
daemon/blkid.mli | 19 ------------
daemon/btrfs.mli | 20 -------------
daemon/devsparts.mli | 25 ----------------
daemon/file.mli | 19 ------------
daemon/filearch.mli | 19 ------------
daemon/findfs.mli | 20 -------------
daemon/inspect.mli | 41 --------------------------
daemon/is.mli | 21 -------------
daemon/ldm.mli | 20 -------------
daemon/link.mli | 19 ------------
daemon/listfs.mli | 19 ------------
daemon/lvm.mli | 19 ------------
daemon/md.mli | 20 -------------
daemon/mount.mli | 22 --------------
daemon/parted.mli | 27 -----------------
daemon/realpath.mli | 20 -------------
daemon/statvfs.mli | 19 ------------
generator/daemon.ml | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++
generator/daemon.mli | 1 +
generator/main.ml | 17 +++++++++++
21 files changed, 118 insertions(+), 369 deletions(-)
delete mode 100644 daemon/blkid.mli
delete mode 100644 daemon/btrfs.mli
delete mode 100644 daemon/devsparts.mli
delete mode 100644 daemon/file.mli
delete mode 100644 daemon/filearch.mli
delete mode 100644 daemon/findfs.mli
delete mode 100644 daemon/inspect.mli
delete mode 100644 daemon/is.mli
delete mode 100644 daemon/ldm.mli
delete mode 100644 daemon/link.mli
delete mode 100644 daemon/listfs.mli
delete mode 100644 daemon/lvm.mli
delete mode 100644 daemon/md.mli
delete mode 100644 daemon/mount.mli
delete mode 100644 daemon/parted.mli
delete mode 100644 daemon/realpath.mli
delete mode 100644 daemon/statvfs.mli
diff --git a/.gitignore b/.gitignore
index bb7026537..e67013478 100644
--- a/.gitignore
+++ b/.gitignore
@@ -185,21 +185,38 @@ Makefile.in
/customize/virt-customize.1
/daemon/.depend
/daemon/actions.h
+/daemon/blkid.mli
+/daemon/btrfs.mli
/daemon/callbacks.ml
/daemon/caml-stubs.c
/daemon/daemon_config.ml
/daemon/daemon_utils_tests
+/daemon/devsparts.mli
/daemon/dispatch.c
+/daemon/file.mli
+/daemon/filearch.mli
+/daemon/findfs.mli
/daemon/guestfsd
/daemon/guestfsd.8
/daemon/guestfsd.exe
+/daemon/inspect.mli
+/daemon/is.mli
+/daemon/ldm.mli
+/daemon/link.mli
+/daemon/listfs.mli
+/daemon/lvm.mli
/daemon/lvm-tokenization.c
+/daemon/md.mli
+/daemon/mount.mli
/daemon/names.c
/daemon/optgroups.c
/daemon/optgroups.h
/daemon/optgroups.ml
/daemon/optgroups.mli
+/daemon/parted.mli
+/daemon/realpath.mli
/daemon/stamp-guestfsd.pod
+/daemon/statvfs.mli
/daemon/structs-cleanups.c
/daemon/structs-cleanups.h
/daemon/structs.ml
diff --git a/daemon/blkid.mli b/daemon/blkid.mli
deleted file mode 100644
index 65a61def4..000000000
--- a/daemon/blkid.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val vfs_type : Mountable.t -> string
diff --git a/daemon/btrfs.mli b/daemon/btrfs.mli
deleted file mode 100644
index ce1c2b66f..000000000
--- a/daemon/btrfs.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val btrfs_subvolume_list : Mountable.t -> Structs.btrfssubvolume list
-val btrfs_subvolume_get_default : Mountable.t -> int64
diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli
deleted file mode 100644
index 7b669c269..000000000
--- a/daemon/devsparts.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val list_devices : unit -> string list
-val list_partitions : unit -> string list
-val part_to_dev : string -> string
-val part_to_partnum : string -> int
-val is_whole_device : string -> bool
-val nr_devices : unit -> int
-val device_index : string -> int
diff --git a/daemon/file.mli b/daemon/file.mli
deleted file mode 100644
index 1e1631840..000000000
--- a/daemon/file.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val file : string -> string
diff --git a/daemon/filearch.mli b/daemon/filearch.mli
deleted file mode 100644
index 3f472af51..000000000
--- a/daemon/filearch.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val file_architecture : string -> string
diff --git a/daemon/findfs.mli b/daemon/findfs.mli
deleted file mode 100644
index c671782c3..000000000
--- a/daemon/findfs.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val findfs_uuid : string -> string
-val findfs_label : string -> string
diff --git a/daemon/inspect.mli b/daemon/inspect.mli
deleted file mode 100644
index 336bbcfae..000000000
--- a/daemon/inspect.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val inspect_os : unit -> Mountable.t list
-val inspect_get_roots : unit -> Mountable.t list
-val inspect_get_mountpoints : Mountable.t -> (string * Mountable.t) list
-val inspect_get_filesystems : Mountable.t -> Mountable.t list
-val inspect_get_format : Mountable.t -> string
-val inspect_get_type : Mountable.t -> string
-val inspect_get_distro : Mountable.t -> string
-val inspect_get_package_format : Mountable.t -> string
-val inspect_get_package_management : Mountable.t -> string
-val inspect_get_product_name : Mountable.t -> string
-val inspect_get_product_variant : Mountable.t -> string
-val inspect_get_major_version : Mountable.t -> int
-val inspect_get_minor_version : Mountable.t -> int
-val inspect_get_arch : Mountable.t -> string
-val inspect_get_hostname : Mountable.t -> string
-val inspect_get_windows_systemroot : Mountable.t -> string
-val inspect_get_windows_software_hive : Mountable.t -> string
-val inspect_get_windows_system_hive : Mountable.t -> string
-val inspect_get_windows_current_control_set : Mountable.t -> string
-val inspect_get_drive_mappings : Mountable.t -> (string * string) list
-val inspect_is_live : Mountable.t -> bool
-val inspect_is_netinst : Mountable.t -> bool
-val inspect_is_multipart : Mountable.t -> bool
diff --git a/daemon/is.mli b/daemon/is.mli
deleted file mode 100644
index f64d33dae..000000000
--- a/daemon/is.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val is_file : ?followsymlinks:bool -> string -> bool
-val is_dir : ?followsymlinks:bool -> string -> bool
-val is_symlink : string -> bool
diff --git a/daemon/ldm.mli b/daemon/ldm.mli
deleted file mode 100644
index 74afdf5d8..000000000
--- a/daemon/ldm.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val list_ldm_volumes : unit -> string list
-val list_ldm_partitions : unit -> string list
diff --git a/daemon/link.mli b/daemon/link.mli
deleted file mode 100644
index f3c6d1564..000000000
--- a/daemon/link.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val readlink : string -> string
diff --git a/daemon/listfs.mli b/daemon/listfs.mli
deleted file mode 100644
index 0e8f24080..000000000
--- a/daemon/listfs.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val list_filesystems : unit -> (Mountable.t * string) list
diff --git a/daemon/lvm.mli b/daemon/lvm.mli
deleted file mode 100644
index 592168433..000000000
--- a/daemon/lvm.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val lvs : unit -> string list
diff --git a/daemon/md.mli b/daemon/md.mli
deleted file mode 100644
index e0c3e08ad..000000000
--- a/daemon/md.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val list_md_devices : unit -> string list
-val md_detail : string -> (string * string) list
diff --git a/daemon/mount.mli b/daemon/mount.mli
deleted file mode 100644
index 9fa5b76e7..000000000
--- a/daemon/mount.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val mount : Mountable.t -> string -> unit
-val mount_ro : Mountable.t -> string -> unit
-val mount_options : string -> Mountable.t -> string -> unit
-val mount_vfs : string -> string -> Mountable.t -> string -> unit
diff --git a/daemon/parted.mli b/daemon/parted.mli
deleted file mode 100644
index 0b7eb87f4..000000000
--- a/daemon/parted.mli
+++ /dev/null
@@ -1,27 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val part_get_mbr_id : string -> int -> int
-val part_list : string -> Structs.partition list
-
-val part_get_parttype : string -> string
-
-val part_get_gpt_type : string -> int -> string
-val part_get_gpt_guid : string -> int -> string
-val part_get_gpt_attributes : string -> int -> int64
-val part_set_gpt_attributes : string -> int -> int64 -> unit
diff --git a/daemon/realpath.mli b/daemon/realpath.mli
deleted file mode 100644
index 10b9ae565..000000000
--- a/daemon/realpath.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val realpath : string -> string
-val case_sensitive_path : string -> string
diff --git a/daemon/statvfs.mli b/daemon/statvfs.mli
deleted file mode 100644
index 13b22f88d..000000000
--- a/daemon/statvfs.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(* guestfs-inspection
- * Copyright (C) 2009-2018 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License along
- * with this program; if not, write to the Free Software Foundation, Inc.,
- * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- *)
-
-val statvfs : string -> Structs.statvfs
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 7fb7052a0..559ed6898 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -490,6 +490,89 @@ let generate_daemon_caml_callbacks_ml () else
pr "let init_callbacks () = ()\n"
+let rec generate_daemon_caml_interface modname () + generate_header OCamlStyle
GPLv2plus;
+
+ let is_ocaml_module_function = function
+ | { impl = OCaml m } when String.is_prefix m (modname ^ ".")
-> true
+ | { impl = OCaml _ } -> false
+ | { impl = C } -> false
+ in
+
+ let ocaml_actions = actions |> (List.filter is_ocaml_module_function) in
+ if ocaml_actions == [] then
+ failwithf "no OCaml implementations for module %s" modname;
+
+ let prefix_length = String.length modname + 1 in
+ List.iter (
+ fun { name; style; impl } ->
+ let ocaml_function + match impl with
+ | OCaml f ->
+ String.sub f prefix_length (String.length f - prefix_length)
+ | C -> assert false in
+
+ generate_ocaml_daemon_prototype ocaml_function style
+ ) ocaml_actions
+
+and generate_ocaml_daemon_prototype name (ret, args, optargs) + let
type_for_stringt = function
+ | Mountable
+ | Mountable_or_Path -> "Mountable.t"
+ | PlainString
+ | Device
+ | Pathname
+ | FileIn
+ | FileOut
+ | Key
+ | GUID
+ | Filename
+ | Dev_or_Path -> "string"
+ in
+ let type_for_rstringt = function
+ | RMountable -> "Mountable.t"
+ | RPlainString
+ | RDevice -> "string"
+ in
+ pr "val %s : " name;
+ List.iter (
+ function
+ | OBool n -> pr "?%s:bool -> " n
+ | OInt n -> pr "?%s:int -> " n
+ | OInt64 n -> pr "?%s:int64 -> " n
+ | OString n -> pr "?%s:string -> " n
+ | OStringList n -> pr "?%s:string array -> " n
+ ) optargs;
+ if args <> [] then
+ List.iter (
+ function
+ | String (typ, _) -> pr "%s -> " (type_for_stringt typ)
+ | BufferIn _ -> pr "string -> "
+ | OptString _ -> pr "string option -> "
+ | StringList (typ, _) -> pr "%s array -> "
(type_for_stringt typ)
+ | Bool _ -> pr "bool -> "
+ | Int _ -> pr "int -> "
+ | Int64 _ | Pointer _ -> pr "int64 -> "
+ ) args
+ else
+ pr "unit -> ";
+ (match ret with
+ | RErr -> pr "unit" (* all errors are turned into exceptions *)
+ | RInt _ -> pr "int"
+ | RInt64 _ -> pr "int64"
+ | RBool _ -> pr "bool"
+ | RConstString _ -> pr "string"
+ | RConstOptString _ -> pr "string option"
+ | RString (typ, _) -> pr "%s" (type_for_rstringt typ)
+ | RBufferOut _ -> pr "string"
+ | RStringList (typ, _) -> pr "%s list" (type_for_rstringt typ)
+ | RStruct (_, typ) -> pr "Structs.%s" typ
+ | RStructList (_, typ) -> pr "Structs.%s list" typ
+ | RHashtable (typea, typeb, _) ->
+ pr "(%s * %s) list" (type_for_rstringt typea)
(type_for_rstringt typeb)
+ );
+ pr "\n"
+
(* Generate stubs for the functions implemented in OCaml.
* Basically we implement the do_<name> function here, and
* have it call out to OCaml code.
diff --git a/generator/daemon.mli b/generator/daemon.mli
index 40bf31302..f0268ba99 100644
--- a/generator/daemon.mli
+++ b/generator/daemon.mli
@@ -21,6 +21,7 @@ val generate_daemon_stubs_h : unit -> unit
val generate_daemon_stubs : Types.action list -> unit -> unit
val generate_daemon_caml_stubs : unit -> unit
val generate_daemon_caml_callbacks_ml : unit -> unit
+val generate_daemon_caml_interface : string -> unit -> unit
val generate_daemon_dispatch : unit -> unit
val generate_daemon_lvm_tokenization : unit -> unit
val generate_daemon_names : unit -> unit
diff --git a/generator/main.ml b/generator/main.ml
index 34bca68d9..e51313779 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -155,6 +155,23 @@ Run it from the top source directory using the command
Daemon.generate_daemon_structs_cleanups_c;
output_to "daemon/structs-cleanups.h"
Daemon.generate_daemon_structs_cleanups_h;
+ let daemon_ocaml_interfaces + List.fold_left (
+ fun set { impl } ->
+ let ocaml_function + match impl with
+ | OCaml f -> fst (String.split "." f)
+ | C -> assert false in
+
+ StringSet.add ocaml_function set
+ ) StringSet.empty (actions |> impl_ocaml_functions) in
+ StringSet.iter (
+ fun modname ->
+ let fn = Char.escaped (Char.lowercase_ascii (String.unsafe_get modname
0)) ^
+ String.sub modname 1 (String.length modname - 1) in
+ output_to (sprintf "daemon/%s.mli" fn)
+ (Daemon.generate_daemon_caml_interface modname)
+ ) daemon_ocaml_interfaces;
output_to "fish/cmds-gperf.gperf"
Fish.generate_fish_cmds_gperf;
--
2.14.3
Richard W.M. Jones
2018-Apr-10 10:47 UTC
Re: [Libguestfs] [PATCH v2 2/5] daemon: use the structs from the Structs module
These two look the same as previously, and so are ACKed as before. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com virt-p2v converts physical machines to virtual machines. Boot with a live CD or over the network (PXE) and turn machines into KVM guests. http://libguestfs.org/virt-v2v
Richard W.M. Jones
2018-Apr-10 10:48 UTC
Re: [Libguestfs] [PATCH v2 3/5] daemon: move Lvm.lv_canonical to new Lvm_utils module
On Tue, Apr 10, 2018 at 12:42:52PM +0200, Pino Toscano wrote:> This way the Lvm module contains only the OCaml implementations of LVM > daemon APIs. > > This is simple refactoring, with no functional changes.Looks like simple code motion as you say, so ACK. Rich.> daemon/Makefile.am | 2 ++ > daemon/findfs.ml | 2 +- > daemon/inspect_fs_unix_fstab.ml | 2 +- > daemon/lvm.ml | 27 ----------------------- > daemon/lvm.mli | 10 --------- > daemon/lvm_utils.ml | 48 +++++++++++++++++++++++++++++++++++++++++ > daemon/lvm_utils.mli | 27 +++++++++++++++++++++++ > 7 files changed, 79 insertions(+), 39 deletions(-) > create mode 100644 daemon/lvm_utils.ml > create mode 100644 daemon/lvm_utils.mli > > diff --git a/daemon/Makefile.am b/daemon/Makefile.am > index 9dbd375f5..9cd34ff75 100644 > --- a/daemon/Makefile.am > +++ b/daemon/Makefile.am > @@ -268,6 +268,7 @@ SOURCES_MLI = \ > link.mli \ > listfs.mli \ > lvm.mli \ > + lvm_utils.mli \ > md.mli \ > mount.mli \ > mountable.mli \ > @@ -296,6 +297,7 @@ SOURCES_ML = \ > ldm.ml \ > link.ml \ > lvm.ml \ > + lvm_utils.ml \ > findfs.ml \ > md.ml \ > mount.ml \ > diff --git a/daemon/findfs.ml b/daemon/findfs.ml > index f613015f0..c24a194e3 100644 > --- a/daemon/findfs.ml > +++ b/daemon/findfs.ml > @@ -44,7 +44,7 @@ and findfs tag str > > if String.is_prefix out "/dev/mapper/" || > String.is_prefix out "/dev/dm-" then ( > - match Lvm.lv_canonical out with > + match Lvm_utils.lv_canonical out with > | None -> > (* Ignore the case where 'out' doesn't appear to be an LV. > * The best we can do is return the original as-is. > diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml > index 43cec2323..edb797e3f 100644 > --- a/daemon/inspect_fs_unix_fstab.ml > +++ b/daemon/inspect_fs_unix_fstab.ml > @@ -327,7 +327,7 @@ and resolve_fstab_device spec md_map os_type > * we have implemented lvm_canonical_lv_name in the daemon. > *) > try > - match Lvm.lv_canonical spec with > + match Lvm_utils.lv_canonical spec with > | None -> Mountable.of_device spec > | Some device -> Mountable.of_device device > with > diff --git a/daemon/lvm.ml b/daemon/lvm.ml > index ed4ed7462..ef45ed4bc 100644 > --- a/daemon/lvm.ml > +++ b/daemon/lvm.ml > @@ -97,30 +97,3 @@ and filter_convert_old_lvs_output out > ) lines in > > List.sort compare lines > - > -(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 > - * to a canonical one. > - * > - * This is harder than it should be. A LV device like /dev/VG/LV is > - * really a symlink to a device-mapper device like /dev/dm-0. However > - * at the device-mapper (kernel) level, nothing is really known about > - * LVM (a userspace concept). Therefore we use a convoluted method to > - * determine this, by listing out known LVs and checking whether the > - * rdev (major/minor) of the device we are passed matches any of them. > - * > - * Note use of 'stat' instead of 'lstat' so that symlinks are fully > - * resolved. > - *) > -let lv_canonical device > - let stat1 = stat device in > - let lvs = lvs () in > - try > - Some ( > - List.find ( > - fun lv -> > - let stat2 = stat lv in > - stat1.st_rdev = stat2.st_rdev > - ) lvs > - ) > - with > - | Not_found -> None > diff --git a/daemon/lvm.mli b/daemon/lvm.mli > index e9a6faeca..592168433 100644 > --- a/daemon/lvm.mli > +++ b/daemon/lvm.mli > @@ -17,13 +17,3 @@ > *) > > val lvs : unit -> string list > - > -val lv_canonical : string -> string option > -(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 > - to a canonical one. > - > - On error this raises an exception. There are two possible non-error > - return cases: > - > - Some lv = conversion was successful, returning the canonical LV > - None = input path was not an LV, it could not be made canonical *) > diff --git a/daemon/lvm_utils.ml b/daemon/lvm_utils.ml > new file mode 100644 > index 000000000..a891193df > --- /dev/null > +++ b/daemon/lvm_utils.ml > @@ -0,0 +1,48 @@ > +(* guestfs-inspection > + * Copyright (C) 2009-2018 Red Hat Inc. > + * > + * This program is free software; you can redistribute it and/or modify > + * it under the terms of the GNU General Public License as published by > + * the Free Software Foundation; either version 2 of the License, or > + * (at your option) any later version. > + * > + * This program 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 General Public License for more details. > + * > + * You should have received a copy of the GNU General Public License along > + * with this program; if not, write to the Free Software Foundation, Inc., > + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. > + *) > + > +open Unix > + > +open Utils > + > +(* Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 > + * to a canonical one. > + * > + * This is harder than it should be. A LV device like /dev/VG/LV is > + * really a symlink to a device-mapper device like /dev/dm-0. However > + * at the device-mapper (kernel) level, nothing is really known about > + * LVM (a userspace concept). Therefore we use a convoluted method to > + * determine this, by listing out known LVs and checking whether the > + * rdev (major/minor) of the device we are passed matches any of them. > + * > + * Note use of 'stat' instead of 'lstat' so that symlinks are fully > + * resolved. > + *) > +let lv_canonical device > + let stat1 = stat device in > + let lvs = Lvm.lvs () in > + try > + Some ( > + List.find ( > + fun lv -> > + let stat2 = stat lv in > + stat1.st_rdev = stat2.st_rdev > + ) lvs > + ) > + with > + | Not_found -> None > diff --git a/daemon/lvm_utils.mli b/daemon/lvm_utils.mli > new file mode 100644 > index 000000000..b25a9a706 > --- /dev/null > +++ b/daemon/lvm_utils.mli > @@ -0,0 +1,27 @@ > +(* guestfs-inspection > + * Copyright (C) 2009-2018 Red Hat Inc. > + * > + * This program is free software; you can redistribute it and/or modify > + * it under the terms of the GNU General Public License as published by > + * the Free Software Foundation; either version 2 of the License, or > + * (at your option) any later version. > + * > + * This program 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 General Public License for more details. > + * > + * You should have received a copy of the GNU General Public License along > + * with this program; if not, write to the Free Software Foundation, Inc., > + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. > + *) > + > +val lv_canonical : string -> string option > +(** Convert a non-canonical LV path like /dev/mapper/vg-lv or /dev/dm-0 > + to a canonical one. > + > + On error this raises an exception. There are two possible non-error > + return cases: > + > + Some lv = conversion was successful, returning the canonical LV > + None = input path was not an LV, it could not be made canonical *) > -- > 2.14.3 > > _______________________________________________ > Libguestfs mailing list > Libguestfs@redhat.com > https://www.redhat.com/mailman/listinfo/libguestfs-- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com libguestfs lets you edit virtual machines. Supports shell scripting, bindings from many languages. http://libguestfs.org
Richard W.M. Jones
2018-Apr-10 10:49 UTC
Re: [Libguestfs] [PATCH v2 4/5] daemon: move Mount.umount_all to new Mount_utils module
And ditto this one, simple code motion so ACK. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com libguestfs lets you edit virtual machines. Supports shell scripting, bindings from many languages. http://libguestfs.org
Richard W.M. Jones
2018-Apr-10 10:50 UTC
Re: [Libguestfs] [PATCH v2 5/5] daemon: autogenerate OCaml interfaces
On Tue, Apr 10, 2018 at 12:42:54PM +0200, Pino Toscano wrote:> Add a way to generate OCaml interfaces for all the modules in the > daemon that implement APIs: this makes sure that for them the > interface of each function matches the actual API specified in the > generator.Looks good now, ACK. Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com Fedora Windows cross-compiler. Compile Windows programs, test, and build Windows installers. Over 100 libraries supported. http://fedoraproject.org/wiki/MinGW
Apparently Analagous Threads
- [PATCH 2/3] daemon: use the structs from the Structs module
- [PATCH v2 15/23] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
- [PATCH 18/27] daemon: Reimplement ‘btrfs_subvolume_list’ and ‘btrfs_subvolume_get_default’ in OCaml.
- [PATCH] listfs: ignore the default btrfs subvolume
- Re: [PATCH] listfs: ignore the default btrfs subvolume