virt-df/virt_df_gettext.ml
po/*.mo
po/*.po.bak
-virt-df/virt_df_lvm2_lexer.ml
-virt-df/virt_df_lvm2_parser.ml
-virt-df/virt_df_lvm2_parser.mli
\ No newline at end of file
+lib/diskimage_lvm2_lexer.ml
+lib/diskimage_lvm2_parser.ml
+lib/diskimage_lvm2_parser.mli
\ No newline at end of file
INSTALL = @INSTALL@
-SUBDIRS = virt-df
+SUBDIRS = lib virt-df
all opt depend install:
for d in $(SUBDIRS); do \
clean:
for d in . $(SUBDIRS); do \
- (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *.opt *~ *.dll *.exe core); \
+ (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a \
+ *.so *.opt *~ *.dll *.exe core); \
done
rm -f virt-df/virt-df
dnl Process this file with autoconf to produce a configure script.
-AC_INIT(virt-df,2.0.0)
+AC_INIT(virt-df,2.0.1)
AC_PROG_INSTALL
AC_CONFIG_HEADERS([config.h])
AC_CONFIG_FILES([Makefile
Make.rules
+ lib/Makefile
po/Makefile
virt-df/Makefile
])
--- /dev/null
+diskimage_ext2.cmi: diskimage_utils.cmi
+diskimage_linux_swap.cmi: diskimage_utils.cmi
+diskimage_lvm2.cmi: diskimage_utils.cmi
+diskimage_lvm2_parser.cmi: diskimage_lvm2_metadata.cmi
+diskimage_mbr.cmi: diskimage_utils.cmi
+diskimage.cmi: /usr/lib64/ocaml/bitmatch/bitmatch.cmi
+diskimage_utils.cmi: /usr/lib64/ocaml/bitmatch/bitmatch.cmi
+diskimage_ext2.cmo: diskimage_utils.cmi \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi
+diskimage_ext2.cmx: diskimage_utils.cmx \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_ext2.cmi
+diskimage_linux_swap.cmo: diskimage_utils.cmi \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi
+diskimage_linux_swap.cmx: diskimage_utils.cmx \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_linux_swap.cmi
+diskimage_lvm2_metadata.cmo: diskimage_lvm2_metadata.cmi
+diskimage_lvm2_metadata.cmx: diskimage_lvm2_metadata.cmi
+diskimage_lvm2.cmo: diskimage_utils.cmi diskimage_lvm2_metadata.cmi \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi
+diskimage_lvm2.cmx: diskimage_utils.cmx diskimage_lvm2_metadata.cmx \
+ /usr/lib64/ocaml/bitmatch/bitmatch.cmi diskimage_lvm2.cmi
+diskimage_lvm2_parser.cmo: diskimage_lvm2_metadata.cmi \
+ diskimage_lvm2_parser.cmi
+diskimage_lvm2_parser.cmx: diskimage_lvm2_metadata.cmx \
+ diskimage_lvm2_parser.cmi
+diskimage_mbr.cmo: diskimage_utils.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi \
+ diskimage_mbr.cmi
+diskimage_mbr.cmx: diskimage_utils.cmx /usr/lib64/ocaml/bitmatch/bitmatch.cmi \
+ diskimage_mbr.cmi
+diskimage.cmo: diskimage_utils.cmi diskimage_mbr.cmi diskimage_lvm2.cmi \
+ diskimage_linux_swap.cmi diskimage_ext2.cmi diskimage.cmi
+diskimage.cmx: diskimage_utils.cmx diskimage_mbr.cmx diskimage_lvm2.cmx \
+ diskimage_linux_swap.cmx diskimage_ext2.cmx diskimage.cmi
+diskimage_utils.cmo: diskimage_utils.cmi
+diskimage_utils.cmx: diskimage_utils.cmi
--- /dev/null
+# virt-df
+# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones
+#
+# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+PACKAGE := @PACKAGE_NAME@
+VERSION := @PACKAGE_VERSION@
+
+INSTALL := @INSTALL@
+HAVE_PERLDOC := @HAVE_PERLDOC@
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+bindir = @bindir@
+
+#OCAMLCPACKAGES := -package unix,extlib,bitmatch
+OCAMLCPACKAGES := -package unix,extlib -I +bitmatch
+
+#----------------------------------------------------------------------
+# Build up the list of object files.
+
+OBJS := diskimage_utils.cmo
+
+# Plugin objects.
+OBJS += diskimage_ext2.cmo \
+ diskimage_linux_swap.cmo \
+ diskimage_lvm2_metadata.cmo \
+ diskimage_lvm2_parser.cmo \
+ diskimage_lvm2_lexer.cmo \
+ diskimage_lvm2.cmo \
+ diskimage_mbr.cmo
+
+OBJS += diskimage.cmo
+
+XOBJS := $(OBJS:.cmo=.cmx)
+
+#----------------------------------------------------------------------
+
+SYNTAX := -pp "camlp4o -I`ocamlc -where`/bitmatch pa_bitmatch.cmo"
+
+OCAMLCFLAGS := -g -w s $(SYNTAX)
+#OCAMLCLIBS := -linkpkg
+OCAMLCLIBS := -linkpkg bitmatch.cma
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS := -w s $(SYNTAX)
+#OCAMLOPTLIBS := $(OCAMLCLIBS)
+OCAMLOPTLIBS := -linkpkg bitmatch.cmxa
+
+OCAMLDEPFLAGS := $(SYNTAX)
+
+BYTE_TARGETS := diskimage.cma
+OPT_TARGETS := diskimage.cmxa
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+diskimage.cma: $(OBJS)
+ ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+ -a -o $@ $^
+
+diskimage.cmxa: $(XOBJS)
+ ocamlfind ocamlopt \
+ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+ -a -o $@ $^
+
+# 'make depend' doesn't catch these dependencies because the .mli file
+# is auto-generated.
+diskimage_lvm2_parser.cmo: diskimage_lvm2_parser.cmi
+diskimage_lvm2_parser.cmx: diskimage_lvm2_parser.cmi
+diskimage_lvm2_parser.cmi: diskimage_lvm2_parser.mli
+
+install:
+ ocamlfind install diskimage *.mli *.cma *.cmx *.cmxa *.a
+
+include ../Make.rules
--- /dev/null
+For user documentation:
+
+Please see the manual page (virt-df.pod or virt-df.txt in this
+directory).
+
+Developer documentation
+----------------------------------------------------------------------
+
+This subdirectory contains a library of useful functions for parsing
+disk images.
+
+It is all based on and uses the pa_bitmatch syntax extension &
+library. You need pa_bitmatch >= 0.5.
+
+This program has suddenly become rather large and confusing.
+Hopefully this documentation should go some way towards explaining
+what is going on inside the source.
+
+The main program consists of two modules:
+
+ - diskimage.ml / diskimage.mli (module name: Diskimage)
+
+ This has evolved into a library of miscellaneous functions
+ and values which are included throughout the rest of the
+ program. If you see an unexplained function then it's
+ likely that it is defined in here.
+
+ Start by reading diskimage.mli which contains the full types
+ and plenty of documentation.
+
+ - diskimage_main.ml
+
+ This is the program. It reads the command line arguments,
+ loads the domain descriptions, calls out to the plug-ins
+ to probe for disks / partitions / filesystems / etc., and
+ finally prints the results.
+
+ The file consists of basically one large program that
+ does all of the above in sequence.
+
+Everything else in this directory is a plug-in specialized for probing
+a particular filesystem, partition scheme or type of LVM. The
+plug-ins at time of writing are:
+
+ - diskimage_ext2.ml / diskimage_ext2.mli
+
+ EXT2/3/4 plug-in.
+
+ - diskimage_linux_swap.ml / diskimage_linux_swap.mli
+
+ Linux swap (new style) plug-in.
+
+ - diskimage_mbr.ml / diskimage_mbr.mli
+
+ Master Boot Record (MS-DOS) disk partitioning plug-in.
+
+ - diskimage_lvm2*
+
+ LVM2 parsing, which is by far the most complex plug-in.
+ It consists of:
+
+ - diskimage_lvm2.ml
+ - diskimage_lvm2.mli
+ LVM2 probing, PV detection.
+
+ - diskimage_lvm2_parser.mly
+ - diskimage_lvm2_lexer.mll
+ Scanner/parser for parsing LVM2 metadata definitions.
+
+ - diskimage_lvm2_metadata.ml
+ - diskimage_lvm2_metadata.mli
+ AST for LVM2 metadata definitions.
--- /dev/null
+(* Diskimage library for reading disk images.
+ (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+open Printf
+open ExtList
+open Unix
+
+include Diskimage_utils
+
+let partition_types = [
+ "MBR", Diskimage_mbr.probe_mbr;
+]
+
+let filesystem_types = [
+ "ext2", Diskimage_ext2.probe_ext2;
+ "linux_swap", Diskimage_linux_swap.probe_swap;
+]
+
+let lvm_types = [
+ "LVM", (Diskimage_lvm2.probe_pv, Diskimage_lvm2.list_lvs);
+]
+
+(* Probe a device for partitions. Returns [Some parts] or [None]. *)
+let probe_for_partitions dev =
+ if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (parts_name, probe_fn) :: rest ->
+ try Some (probe_fn dev)
+ with Not_found -> loop rest
+ in
+ let r = loop partition_types in
+ if !debug then (
+ match r with
+ | None -> eprintf "no partitions found on %s\n%!" dev#name
+ | Some { parts_name = name; parts = parts } ->
+ eprintf "found %d %s partitions on %s:\n"
+ (List.length parts) name dev#name;
+ List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
+ );
+ r
+
+(* Probe a device for a filesystem. Returns [Some fs] or [None]. *)
+let probe_for_filesystem dev =
+ if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (fs_name, probe_fn) :: rest ->
+ try Some (probe_fn dev)
+ with Not_found -> loop rest
+ in
+ let r = loop filesystem_types in
+ if !debug then (
+ match r with
+ | None -> eprintf "no filesystem found on %s\n%!" dev#name
+ | Some fs ->
+ eprintf "found a filesystem on %s:\n" dev#name;
+ eprintf "\t%s\n%!" (string_of_filesystem fs)
+ );
+ r
+
+(* Probe a device for a PV. Returns [Some lvm_name] or [None]. *)
+let probe_for_pv dev =
+ if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
+ let rec loop = function
+ | [] -> None
+ | (lvm_name, (probe_fn, _)) :: rest ->
+ try Some (probe_fn lvm_name dev)
+ with Not_found -> loop rest
+ in
+ let r = loop lvm_types in
+ if !debug then (
+ match r with
+ | None -> eprintf "no PV found on %s\n%!" dev#name
+ | Some { lvm_plugin_id = name } ->
+ eprintf "%s contains a %s PV\n%!" dev#name name
+ );
+ r
+
+let list_lvs lvm_name devs =
+ let _, list_lvs_fn = List.assoc lvm_name lvm_types in
+ list_lvs_fn devs
+
+(* Create machine description. *)
+let open_machine name disks =
+ let disks = List.map (
+ fun (name, path) ->
+ let dev = new block_device path in
+ { d_name = name; d_dev = dev; d_content = `Unknown }
+ ) disks in
+ { m_name = name; m_disks = disks; m_lv_filesystems = [] }
+
+let close_machine { m_disks = m_disks } =
+ (* Only close the disks, assume all other devices are derived from them. *)
+ List.iter (fun { d_dev = d_dev } -> d_dev#close ()) m_disks
+
+let scan_machine ({ m_disks = m_disks } as machine) =
+ let m_disks = List.map (
+ fun ({ d_dev = dev } as disk) ->
+ (* See if it is partitioned first. *)
+ let parts = probe_for_partitions dev in
+ match parts with
+ | Some parts ->
+ { disk with d_content = `Partitions parts }
+ | None ->
+ (* Not partitioned. Does it contain a filesystem? *)
+ let fs = probe_for_filesystem dev in
+ match fs with
+ | Some fs ->
+ { disk with d_content = `Filesystem fs }
+ | None ->
+ (* Not partitioned, no filesystem, is it a PV? *)
+ let pv = probe_for_pv dev in
+ match pv with
+ | Some lvm_name ->
+ { disk with d_content = `PhysicalVolume lvm_name }
+ | None ->
+ disk (* Spare/unknown. *)
+ ) m_disks in
+
+ (* Now we have either detected partitions or a filesystem on each
+ * physical device (or perhaps neither). See what is on those
+ * partitions.
+ *)
+ let m_disks = List.map (
+ function
+ | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
+ let ps = List.map (
+ fun p ->
+ if p.part_status = Bootable || p.part_status = Nonbootable then (
+ let fs = probe_for_filesystem p.part_dev in
+ match fs with
+ | Some fs ->
+ { p with part_content = `Filesystem fs }
+ | None ->
+ (* Is it a PV? *)
+ let pv = probe_for_pv p.part_dev in
+ match pv with
+ | Some lvm_name ->
+ { p with part_content = `PhysicalVolume lvm_name }
+ | None ->
+ p (* Spare/unknown. *)
+ ) else p
+ ) parts.parts in
+ let parts = { parts with parts = ps } in
+ { disk with d_content = `Partitions parts }
+ | disk -> disk
+ ) m_disks in
+
+ (* LVM filesystem detection
+ *
+ * Look for all disks/partitions which have been identified as PVs
+ * and pass those back to the respective LVM plugin for LV detection.
+ *
+ * (Note - a two-stage process because an LV can be spread over
+ * several PVs, so we have to detect all PVs belonging to a
+ * domain first).
+ *
+ * XXX To deal with RAID (ie. md devices) we will need to loop
+ * around here because RAID is like LVM except that they normally
+ * present as block devices which can be used by LVM.
+ *)
+ (* First: LV detection.
+ * Find all physical volumes, can be disks or partitions.
+ *)
+ let pvs_on_disks = List.filter_map (
+ function
+ | { d_dev = d_dev;
+ d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
+ | _ -> None
+ ) m_disks in
+ let pvs_on_partitions = List.map (
+ function
+ | { d_content = `Partitions { parts = parts } } ->
+ List.filter_map (
+ function
+ | { part_dev = part_dev;
+ part_content = `PhysicalVolume pv } ->
+ Some (pv, part_dev)
+ | _ -> None
+ ) parts
+ | _ -> []
+ ) m_disks in
+ let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
+
+ (* Second: filesystem on LV detection.
+ * Group the LVs by plug-in type.
+ *)
+ let cmp (a,_) (b,_) = compare a b in
+ let lvs = List.sort ~cmp lvs in
+ let lvs = group_by lvs in
+
+ let lvs =
+ List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
+ let lvs = List.concat lvs in
+
+ (* lvs is a list of potential LV devices. Now run them through the
+ * probes to see if any contain filesystems.
+ *)
+ let filesystems =
+ List.filter_map (
+ fun ({ lv_dev = dev } as lv) ->
+ match probe_for_filesystem dev with
+ | Some fs -> Some (lv, fs)
+ | None -> None
+ ) lvs in
+
+ { machine with
+ m_disks = m_disks;
+ m_lv_filesystems = filesystems }
--- /dev/null
+(** Diskimage library for reading disk images. *)
+(* (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(**
+ {2 Machine/device model}
+
+ The "machine/device model" that we currently understand looks
+ like this:
+
+{v
+machines
+ |
+ \--- host partitions / disk image files
+ ||
+ guest block devices
+ |
+ +--> guest partitions (eg. using MBR)
+ | |
+ \-(1)->+--- filesystems (eg. ext3)
+ |
+ \--- PVs for LVM
+ |||
+ VGs and LVs
+v}
+
+ (1) Filesystems and PVs may also appear directly on guest
+ block devices.
+
+ Partition schemes (eg. MBR) and filesystems register themselves
+ with this main module and they are queried first to get an idea
+ of the physical devices, partitions and filesystems potentially
+ available to the guest.
+
+ Volume management schemes (eg. LVM2) register themselves here
+ and are called later with "spare" physical devices and partitions
+ to see if they contain LVM data. If this results in additional
+ logical volumes then these are checked for filesystems.
+
+ Swap space is considered to be a dumb filesystem for the purposes
+ of this discussion.
+*)
+
+class virtual device :
+ object
+ method virtual name : string
+ (** Return some printable name for the device. *)
+ method virtual size : int64
+ (** Return the size of the device in bytes.
+
+ Note: For some types of devices, the device may have
+ "holes", alignment requirements, etc. so this method doesn't
+ imply that every byte from [0..size-1] is readable. *)
+ method close : unit -> unit
+ (** Close the device. This must be called to fully free up
+ any resources used by the device. *)
+ method virtual read : int64 -> int -> string
+ (** [read offset len] reads len bytes starting at offset. *)
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ (** [read_bitstring] is the same as [read] but returns
+ a pa_bitmatch-style bitstring. *)
+ end
+ (**
+ A virtual (or physical!) device, encapsulating any translation
+ that has to be done to access the device. eg. For partitions
+ there is a simple offset, but for LVM you may need complicated
+ table lookups.
+
+ Note this very rare use of OOP in OCaml!
+ *)
+
+class block_device : string ->
+ object
+ method name : string
+ method size : int64
+ method close : unit -> unit
+ method read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ end
+ (** A concrete device which just direct-maps a file or /dev device. *)
+
+class offset_device : string -> int64 -> int64 -> device ->
+ object
+ method name : string
+ method size : int64
+ method close : unit -> unit
+ method read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ end
+ (** A concrete device which maps a linear part of an underlying device.
+
+ [new offset_device name start size dev] creates a new
+ device which maps bytes from [start] to [start+size-1]
+ of the underlying device [dev] (ie. in this device they
+ appear as bytes [0] to [size-1]).
+
+ Useful for things like partitions.
+ *)
+
+val null_device : device
+ (** The null device. Any attempt to read generates an error. *)
+
+type machine = {
+ m_name : string; (** Machine name. *)
+ m_disks : disk list; (** Machine disks. *)
+ m_lv_filesystems :
+ (lv * filesystem) list; (** Machine LV filesystems. *)
+}
+ (** A 'machine' is just a convenient holder for collections of disks. *)
+
+and disk = {
+ d_name : string; (** Device name (eg "hda") *)
+ d_dev : device; (** Disk device. *)
+ d_content : disk_content; (** What's on it. *)
+}
+ (** A single physical disk image. *)
+
+and disk_content =
+ [ `Filesystem of filesystem (** Contains a direct filesystem. *)
+ | `Partitions of partitions (** Contains partitions. *)
+ | `PhysicalVolume of pv (** Contains an LVM PV. *)
+ | `Unknown (** Not probed or unknown. *)
+ ]
+
+and partitions = {
+ parts_name : string; (** Name of partitioning scheme. *)
+ parts : partition list; (** Partitions. *)
+}
+and partition = {
+ part_status : partition_status; (** Bootable, etc. *)
+ part_type : int; (** Partition filesystem type. *)
+ part_dev : device; (** Partition device. *)
+ part_content : partition_content; (** What's on it. *)
+}
+ (** Partitions as found on a disk image. *)
+
+and partition_status = Bootable | Nonbootable | Malformed | NullEntry
+and partition_content =
+ [ `Filesystem of filesystem (** Filesystem. *)
+ | `PhysicalVolume of pv (** Contains an LVM PV. *)
+ | `Unknown (** Not probed or unknown. *)
+ ]
+
+and filesystem = {
+ fs_name : string; (** Name of filesystem. *)
+ fs_block_size : int64; (** Block size (bytes). *)
+ fs_blocks_total : int64; (** Total blocks. *)
+ fs_is_swap : bool; (** If swap, following not valid. *)
+ fs_blocks_reserved : int64; (** Blocks reserved for super-user. *)
+ fs_blocks_avail : int64; (** Blocks free (available). *)
+ fs_blocks_used : int64; (** Blocks in use. *)
+ fs_inodes_total : int64; (** Total inodes. *)
+ fs_inodes_reserved : int64; (** Inodes reserved for super-user. *)
+ fs_inodes_avail : int64; (** Inodes free (available). *)
+ fs_inodes_used : int64; (** Inodes in use. *)
+}
+ (** A filesystem. *)
+
+and pv = {
+ lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected
+ this. *)
+ pv_uuid : string; (** UUID. *)
+}
+and lv = {
+ lv_dev : device; (** Logical volume device. *)
+}
+ (** Physical and logical volumes as used by LVM plug-ins. *)
+
+and lvm_plugin_id
+
+val string_of_partition : partition -> string
+val string_of_filesystem : filesystem -> string
+ (** Convert a partition or filesystem struct to a string (for debugging). *)
+
+(** {2 Scanning functions} *)
+
+val open_machine : string -> (string * string) list -> machine
+ (** [open_machine m_name devs]
+ creates a {!machine} containing the devices listed.
+
+ [devs] is a list of pairs of [(name, path)] elements
+ where [name] is something like ["hda"] and [path]
+ is a path to a disk image or [/dev] device.
+
+ This function does not do any scanning, so all disk
+ contents are just set to [`Unknown] and there are no
+ LV filesystems in the returned structure.
+ *)
+
+val close_machine : machine -> unit
+ (** This is a convenience function which calls the [dev#close]
+ method on any open devices owned by the machine. This just
+ has the effect of closing any file descriptors which are
+ opened by these devices.
+ *)
+
+val scan_machine : machine -> machine
+ (** This does a complete scan of all devices owned by a machine,
+ identifying all partitions, filesystems, physical and logical
+ volumes that are known to this library.
+
+ Returns an updated {!machine} structure with the scan results.
+ *)
+
+(** {2 Debugging} *)
+
+val debug : bool ref
+ (** If set to true, functions emit debugging information to stderr. *)
open Unix
open Printf
-open Virt_df_gettext.Gettext
-open Virt_df
+open Diskimage_utils
let superblock_offset = 1024L
let overhead = (* XXX *) overhead in
{
- fs_name = s_ "Linux ext2/3";
+ fs_name = "Linux ext2/3";
fs_block_size = block_size;
fs_blocks_total = Int64.of_int32 s_blocks_count -^ overhead;
fs_is_swap = false;
| { _ } ->
raise Not_found (* Not an EXT2/3 superblock. *)
-
-(* Register with main code. *)
-let () = filesystem_type_register "ext2" probe_ext2
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* This file is empty to stop this plug-in from exporting any
- symbols to other modules by accident.
-*)
+(**/**)
+
+val probe_ext2 : Diskimage_utils.device -> Diskimage_utils.filesystem
Support for Linux swap partitions.
*)
-open Virt_df_gettext.Gettext
-open Virt_df
+open Diskimage_utils
let probe_swap dev =
(* Load the "superblock" (ie. first 0x1000 bytes). *)
"SWAPSPACE2" : 80 : string
} ->
{
- fs_name = s_ "Linux swap";
+ fs_name = "Linux swap";
fs_block_size = 4096L; (* XXX *)
fs_blocks_total = dev#size /^ 4096L;
}
| { _ } ->
raise Not_found (* Not Linux swapspace. *)
-
-(* Register with main code. *)
-let () = filesystem_type_register "linux_swap" probe_swap
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* This file is empty to stop this plug-in from exporting any
- symbols to other modules by accident.
-*)
+(**/**)
+
+val probe_swap : Diskimage_utils.device -> Diskimage_utils.filesystem
open Printf
open ExtList
-open Virt_df_gettext.Gettext
-open Virt_df
-
-open Virt_df_lvm2_metadata
+open Diskimage_utils
+open Diskimage_lvm2_metadata
let plugin_name = "LVM2"
(* Parse the metadata using the external lexer/parser. *)
let pvs = List.map (
fun (uuid, (metadata, dev)) ->
- uuid, (Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata,
+ uuid, (Diskimage_lvm2_lexer.parse_lvm2_metadata_from_string metadata,
dev)
) pvs in
(* Return the list of LV devices. *)
lvs
-
-(*----------------------------------------------------------------------*)
-(* Register with main code. *)
-let () =
- lvm_type_register plugin_name probe_pv list_lvs
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* This file is empty to stop this plug-in from exporting any
- symbols to other modules by accident.
-*)
+(**/**)
+
+val probe_pv :
+ Diskimage_utils.lvm_plugin_id -> Diskimage_utils.device ->
+ Diskimage_utils.pv
+val list_lvs : Diskimage_utils.device list -> Diskimage_utils.lv list
open Printf
open Lexing
- open Virt_df
- open Virt_df_lvm2_parser
+ open Diskimage_lvm2_parser
+ open Diskimage_utils
(* Temporary buffer used for parsing strings, etc. *)
let tmp = Buffer.create 80
*/
%{
- open Virt_df_lvm2_metadata
+ open Diskimage_lvm2_metadata
%}
%token LBRACE RBRACE /* { } */
%token EOF /* end of file */
%start input
-%type <Virt_df_lvm2_metadata.metadata> input
+%type <Diskimage_lvm2_metadata.metadata> input
%%
open Unix
open ExtList
-open Virt_df_gettext.Gettext
-open Virt_df
+open Diskimage_utils
let sector_size = 512
let sector_size64 = 512L
let i64 = Int64.of_int32 u32 in
if u32 >= 0l then i64
else Int64.add i64 0x1_0000_0000_L
-
-(* Register with main code. *)
-let () = partition_type_register "MBR" probe_mbr
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)
-(* This file is empty to stop this plug-in from exporting any
- symbols to other modules by accident.
-*)
+(**/**)
+
+val probe_mbr : Diskimage_utils.device -> Diskimage_utils.partitions
--- /dev/null
+(* Diskimage library for reading disk images.
+ (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+open Printf
+open Unix
+
+let debug = ref false
+
+let ( +* ) = Int32.add
+let ( -* ) = Int32.sub
+let ( ** ) = Int32.mul
+let ( /* ) = Int32.div
+
+let ( +^ ) = Int64.add
+let ( -^ ) = Int64.sub
+let ( *^ ) = Int64.mul
+let ( /^ ) = Int64.div
+
+class virtual device =
+object (self)
+ method virtual read : int64 -> int -> string
+ method virtual size : int64
+ method virtual name : string
+
+ method close () = ()
+
+ (* Helper method to read a chunk of data into a bitstring. *)
+ method read_bitstring offset len =
+ let str = self#read offset len in
+ (str, 0, len * 8)
+end
+
+(* A concrete device which just direct-maps a file or /dev device. *)
+class block_device filename =
+ let fd = openfile filename [ O_RDONLY ] 0 in
+ let size = (LargeFile.fstat fd).LargeFile.st_size in
+object (self)
+ inherit device
+ method read offset len =
+ ignore (LargeFile.lseek fd offset SEEK_SET);
+ let str = String.make len '\000' in
+ read fd str 0 len;
+ str
+ method close () = close fd
+ method size = size
+ method name = filename
+end
+
+(* A linear offset/size from an underlying device. *)
+class offset_device name start size (dev : device) =
+object
+ inherit device
+ method name = name
+ method size = size
+ (* method close () = dev#close () - NB: NO!! Device may be shared. *)
+ method read offset len =
+ if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
+ invalid_arg (
+ sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
+ name offset len size
+ );
+ dev#read (start+^offset) len
+end
+
+(* The null device. Any attempt to read generates an error. *)
+let null_device : device =
+object
+ inherit device
+ method read _ _ = assert false
+ method size = 0L
+ method name = "null"
+end
+
+type machine = {
+ m_name : string; (* Machine name. *)
+ m_disks : disk list; (* Machine disks. *)
+ m_lv_filesystems :
+ (lv * filesystem) list; (* Machine LV filesystems. *)
+}
+and disk = {
+ d_name : string; (* Device name (eg "hda") *)
+
+ (* About the device itself. *)
+ d_dev : device; (* Disk device. *)
+ d_content : disk_content; (* What's on it. *)
+}
+and disk_content =
+ [ `Unknown (* Not probed or unknown. *)
+ | `Partitions of partitions (* Contains partitions. *)
+ | `Filesystem of filesystem (* Contains a filesystem directly. *)
+ | `PhysicalVolume of pv (* Contains an LVM PV. *)
+ ]
+
+(* Partitions. *)
+
+and partitions = {
+ parts_name : string; (* Name of partitioning scheme. *)
+ parts : partition list (* Partitions. *)
+}
+and partition = {
+ part_status : partition_status; (* Bootable, etc. *)
+ part_type : int; (* Partition filesystem type. *)
+ part_dev : device; (* Partition device. *)
+ part_content : partition_content; (* What's on it. *)
+}
+and partition_status = Bootable | Nonbootable | Malformed | NullEntry
+and partition_content =
+ [ `Unknown (* Not probed or unknown. *)
+ | `Filesystem of filesystem (* Filesystem. *)
+ | `PhysicalVolume of pv (* Contains an LVM PV. *)
+ ]
+
+(* Filesystems (also swap devices). *)
+and filesystem = {
+ fs_name : string; (* Name of filesystem. *)
+ fs_block_size : int64; (* Block size (bytes). *)
+ fs_blocks_total : int64; (* Total blocks. *)
+ fs_is_swap : bool; (* If swap, following not valid. *)
+ fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
+ fs_blocks_avail : int64; (* Blocks free (available). *)
+ fs_blocks_used : int64; (* Blocks in use. *)
+ fs_inodes_total : int64; (* Total inodes. *)
+ fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
+ fs_inodes_avail : int64; (* Inodes free (available). *)
+ fs_inodes_used : int64; (* Inodes in use. *)
+}
+
+(* Physical volumes. *)
+and pv = {
+ lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *)
+ pv_uuid : string; (* UUID. *)
+}
+
+(* Logical volumes. *)
+and lv = {
+ lv_dev : device; (* Logical volume device. *)
+}
+
+and lvm_plugin_id = string
+
+(* Convert partition, filesystem types to printable strings for debugging. *)
+let string_of_partition
+ { part_status = status; part_type = typ; part_dev = dev } =
+ sprintf "%s: %s partition type %d"
+ dev#name
+ (match status with
+ | Bootable -> "bootable"
+ | Nonbootable -> "nonbootable"
+ | Malformed -> "malformed"
+ | NullEntry -> "empty")
+ typ
+
+let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
+ if not swap then name
+ else name ^ " [swap]"
+
+(* Convert a UUID (containing '-' chars) to canonical form. *)
+let canonical_uuid uuid =
+ let uuid' = String.make 32 ' ' in
+ let j = ref 0 in
+ for i = 0 to String.length uuid - 1 do
+ if !j >= 32 then invalid_arg "canonical_uuid";
+ let c = uuid.[i] in
+ if c <> '-' then ( uuid'.[!j] <- c; incr j )
+ done;
+ if !j <> 32 then invalid_arg "canonical_uuid";
+ uuid'
+
+(* This version by Isaac Trotts. *)
+let group_by ?(cmp = Pervasives.compare) ls =
+ let ls' =
+ List.fold_left
+ (fun acc (day1, x1) ->
+ match acc with
+ [] -> [day1, [x1]]
+ | (day2, ls2) :: acctl ->
+ if cmp day1 day2 = 0
+ then (day1, x1 :: ls2) :: acctl
+ else (day1, [x1]) :: acc)
+ []
+ ls
+ in
+ let ls' = List.rev ls' in
+ List.map (fun (x, xs) -> x, List.rev xs) ls'
+
+let rec range a b =
+ if a < b then a :: range (a+1) b
+ else []
--- /dev/null
+(* (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
+ http://libvirt.org/
+
+ 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., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+(**/**)
+
+val debug : bool ref
+
+(** {2 Device model} *)
+
+class virtual device :
+ object
+ method virtual name : string
+ method virtual size : int64
+ method close : unit -> unit
+ method virtual read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ end
+
+class block_device : string ->
+ object
+ method name : string
+ method size : int64
+ method close : unit -> unit
+ method read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ end
+
+class offset_device : string -> int64 -> int64 -> device ->
+ object
+ method name : string
+ method size : int64
+ method close : unit -> unit
+ method read : int64 -> int -> string
+ method read_bitstring : int64 -> int -> Bitmatch.bitstring
+ end
+
+val null_device : device
+
+type machine = {
+ m_name : string;
+ m_disks : disk list;
+ m_lv_filesystems :
+ (lv * filesystem) list;
+}
+
+and disk = {
+ d_name : string;
+ d_dev : device;
+ d_content : disk_content;
+}
+
+and disk_content =
+ [ `Filesystem of filesystem
+ | `Partitions of partitions
+ | `PhysicalVolume of pv
+ | `Unknown
+ ]
+
+and partitions = {
+ parts_name : string;
+ parts : partition list;
+}
+and partition = {
+ part_status : partition_status;
+ part_type : int;
+ part_dev : device;
+ part_content : partition_content;
+}
+
+and partition_status = Bootable | Nonbootable | Malformed | NullEntry
+and partition_content =
+ [ `Filesystem of filesystem
+ | `PhysicalVolume of pv
+ | `Unknown
+ ]
+
+and filesystem = {
+ fs_name : string;
+ fs_block_size : int64;
+ fs_blocks_total : int64;
+ fs_is_swap : bool;
+ fs_blocks_reserved : int64;
+ fs_blocks_avail : int64;
+ fs_blocks_used : int64;
+ fs_inodes_total : int64;
+ fs_inodes_reserved : int64;
+ fs_inodes_avail : int64;
+ fs_inodes_used : int64;
+}
+
+and pv = {
+ lvm_plugin_id : lvm_plugin_id;
+ pv_uuid : string;
+}
+and lv = {
+ lv_dev : device;
+}
+
+and lvm_plugin_id = string
+
+val string_of_partition : partition -> string
+val string_of_filesystem : filesystem -> string
+
+(** {2 Internal functions used by the plug-ins} *)
+
+val canonical_uuid : string -> string
+ (** Convert a UUID which may contain '-' characters to canonical form. *)
+
+val group_by : ?cmp:('a -> 'a -> int) -> ('a * 'b) list -> ('a * 'b list) list
+(** Group a sorted list of pairs by the first element of the pair. *)
+
+val range : int -> int -> int list
+(** [range a b] returns the list of integers [a <= i < b].
+ If [a >= b] then the empty list is returned.
+*)
+
+val ( +* ) : int32 -> int32 -> int32
+val ( -* ) : int32 -> int32 -> int32
+val ( ** ) : int32 -> int32 -> int32
+val ( /* ) : int32 -> int32 -> int32
+
+val ( +^ ) : int64 -> int64 -> int64
+val ( -^ ) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val ( /^ ) : int64 -> int64 -> int64
+(** int32 and int64 infix operators for convenience. *)
-virt_df_lvm2_parser.cmi: virt_df_lvm2_metadata.cmi
virt_df_csv.cmo: virt_df.cmi virt_df_csv.cmi
virt_df_csv.cmx: virt_df.cmx virt_df_csv.cmi
-virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi
-virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi
-virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi
-virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi
-virt_df_lvm2_metadata.cmo: virt_df_lvm2_metadata.cmi
-virt_df_lvm2_metadata.cmx: virt_df_lvm2_metadata.cmi
-virt_df_lvm2.cmo: virt_df_lvm2_metadata.cmi virt_df_gettext.cmo virt_df.cmi \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi
-virt_df_lvm2.cmx: virt_df_lvm2_metadata.cmx virt_df_gettext.cmx virt_df.cmx \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi
-virt_df_lvm2_parser.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_parser.cmi
-virt_df_lvm2_parser.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_parser.cmi
-virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi
-virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx
-virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi
-virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \
- /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi
+virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi ../lib/diskimage.cmi
+virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx ../lib/diskimage.cmx
virt_df.cmo: virt_df_gettext.cmo virt_df.cmi
virt_df.cmx: virt_df_gettext.cmx virt_df.cmi
pkg_gettext = @pkg_gettext@
-#OCAMLCPACKAGES := -package unix,extlib,xml-light,bitmatch
-OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt -I +bitmatch
+#OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt,bitmatch -I ../lib
+OCAMLCPACKAGES := -package unix,extlib,xml-light,libvirt -I +bitmatch -I ../lib
ifneq ($(pkg_gettext),no)
OCAMLCPACKAGES += -package gettext-stub
# Library objects.
OBJS := virt_df_gettext.cmo virt_df.cmo
-# Plugin objects.
-OBJS += virt_df_ext2.cmo \
- virt_df_linux_swap.cmo \
- virt_df_lvm2_metadata.cmo \
- virt_df_lvm2_parser.cmo \
- virt_df_lvm2_lexer.cmo \
- virt_df_lvm2.cmo \
- virt_df_mbr.cmo
-
+# Plug-in objects.
ifneq ($(pkg_csv),no)
OCAMLCPACKAGES += -package csv
OBJS += virt_df_csv.cmo
#----------------------------------------------------------------------
-SYNTAX := -pp "camlp4o -I`ocamlc -where`/bitmatch pa_bitmatch.cmo"
-
-OCAMLCFLAGS := -g -w s $(SYNTAX)
-#OCAMLCLIBS := -linkpkg
-OCAMLCLIBS := -linkpkg bitmatch.cma
+OCAMLCFLAGS := -g -w s
+#OCAMLCLIBS := -linkpkg diskimage.cma
+OCAMLCLIBS := -linkpkg bitmatch.cma diskimage.cma
OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
-OCAMLOPTFLAGS := -w s $(SYNTAX)
-#OCAMLOPTLIBS := $(OCAMLCLIBS)
-OCAMLOPTLIBS := -linkpkg bitmatch.cmxa
-
-OCAMLDEPFLAGS := $(SYNTAX)
+OCAMLOPTFLAGS := -w s
+#OCAMLOPTLIBS := -linkpkg diskimage.cmxa
+OCAMLOPTLIBS := -linkpkg bitmatch.cmxa diskimage.cmxa
BYTE_TARGETS := virt-df
OPT_TARGETS := virt-df.opt
$(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
-o $@ $^
-# 'make depend' doesn't catch these dependencies because the .mli file
-# is auto-generated.
-virt_df_lvm2_parser.cmi: virt_df_lvm2_parser.mli
-virt_df_lvm2_parser.cmo: virt_df_lvm2_parser.mli
-virt_df_lvm2_parser.cmx: virt_df_lvm2_parser.mli
-
# Manual page.
ifeq ($(HAVE_PERLDOC),perldoc)
virt-df.1: virt-df.pod
Developer documentation
----------------------------------------------------------------------
-This program has suddenly become rather large and confusing.
-Hopefully this documentation should go some way towards explaining
-what is going on inside the source.
-
-The main program consists of two modules:
-
- - virt_df.ml / virt_df.mli (module name: Virt_df)
-
- This has evolved into a library of miscellaneous functions
- and values which are included throughout the rest of the
- program. If you see an unexplained function then it's
- likely that it is defined in here.
-
- Start by reading virt_df.mli which contains the full types
- and plenty of documentation.
-
- - virt_df_main.ml
-
- This is the program. It reads the command line arguments,
- loads the domain descriptions, calls out to the plug-ins
- to probe for disks / partitions / filesystems / etc., and
- finally prints the results.
-
- The file consists of basically one large program that
- does all of the above in sequence.
-
-Everything else in this directory is a plug-in specialized for probing
-a particular filesystem, partition scheme or type of LVM. The
-plug-ins at time of writing are:
-
- - virt_df_ext2.ml / virt_df_ext2.mli
-
- EXT2/3/4 plug-in.
-
- - virt_df_linux_swap.ml / virt_df_linux_swap.mli
-
- Linux swap (new style) plug-in.
-
- - virt_df_mbr.ml / virt_df_mbr.mli
-
- Master Boot Record (MS-DOS) disk partitioning plug-in.
-
- - virt_df_lvm2*
-
- LVM2 parsing, which is by far the most complex plug-in.
- It consists of:
-
- - virt_df_lvm2.ml
- - virt_df_lvm2.mli
- LVM2 probing, PV detection.
-
- - virt_df_lvm2_parser.mly
- - virt_df_lvm2_lexer.mll
- Scanner/parser for parsing LVM2 metadata definitions.
-
- - virt_df_lvm2_metadata.ml
- - virt_df_lvm2_metadata.mli
- AST for LVM2 metadata definitions.
+Please see ../lib/README.
\ No newline at end of file
open Printf
open ExtList
-open Unix
open Virt_df_gettext.Gettext
-let ( +* ) = Int32.add
-let ( -* ) = Int32.sub
-let ( ** ) = Int32.mul
-let ( /* ) = Int32.div
-
-let ( +^ ) = Int64.add
-let ( -^ ) = Int64.sub
-let ( *^ ) = Int64.mul
-let ( /^ ) = Int64.div
-
(* Command line arguments. *)
let debug = ref false
let uri = ref None
(* Support for CSV (overridden by virt_df_csv.ml, if present). *)
let csv_write = ref None
-
-class virtual device =
-object (self)
- method virtual read : int64 -> int -> string
- method virtual size : int64
- method virtual name : string
-
- (* Helper method to read a chunk of data into a bitstring. *)
- method read_bitstring offset len =
- let str = self#read offset len in
- (str, 0, len * 8)
-end
-
-(* A concrete device which just direct-maps a file or /dev device. *)
-class block_device filename =
- let fd = openfile filename [ O_RDONLY ] 0 in
- let size = (LargeFile.fstat fd).LargeFile.st_size in
-object (self)
- inherit device
- method read offset len =
- ignore (LargeFile.lseek fd offset SEEK_SET);
- let str = String.make len '\000' in
- read fd str 0 len;
- str
- method size = size
- method name = filename
-end
-
-(* A linear offset/size from an underlying device. *)
-class offset_device name start size (dev : device) =
-object
- inherit device
- method name = name
- method size = size
- method read offset len =
- if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
- invalid_arg (
- sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
- name offset len size
- );
- dev#read (start+^offset) len
-end
-
-(* The null device. Any attempt to read generates an error. *)
-let null_device : device =
-object
- inherit device
- method read _ _ = assert false
- method size = 0L
- method name = "null"
-end
-
-type domain = {
- dom_name : string; (* Domain name. *)
- dom_id : int option; (* Domain ID (if running). *)
- dom_disks : disk list; (* Domain disks. *)
- dom_lv_filesystems :
- (lv * filesystem) list; (* Domain LV filesystems. *)
-}
-and disk = {
- (* From the XML ... *)
- d_type : string option; (* The <disk type=...> *)
- d_device : string; (* The <disk device=...> (eg "disk") *)
- d_source : string; (* The <source file=... or dev> *)
- d_target : string; (* The <target dev=...> (eg "hda") *)
-
- (* About the device itself. *)
- d_dev : device; (* Disk device. *)
- d_content : disk_content; (* What's on it. *)
-}
-and disk_content =
- [ `Unknown (* Not probed or unknown. *)
- | `Partitions of partitions (* Contains partitions. *)
- | `Filesystem of filesystem (* Contains a filesystem directly. *)
- | `PhysicalVolume of pv (* Contains an LVM PV. *)
- ]
-
-(* Partitions. *)
-
-and partitions = {
- parts_name : string; (* Name of partitioning scheme. *)
- parts : partition list (* Partitions. *)
-}
-and partition = {
- part_status : partition_status; (* Bootable, etc. *)
- part_type : int; (* Partition filesystem type. *)
- part_dev : device; (* Partition device. *)
- part_content : partition_content; (* What's on it. *)
-}
-and partition_status = Bootable | Nonbootable | Malformed | NullEntry
-and partition_content =
- [ `Unknown (* Not probed or unknown. *)
- | `Filesystem of filesystem (* Filesystem. *)
- | `PhysicalVolume of pv (* Contains an LVM PV. *)
- ]
-
-(* Filesystems (also swap devices). *)
-and filesystem = {
- fs_name : string; (* Name of filesystem. *)
- fs_block_size : int64; (* Block size (bytes). *)
- fs_blocks_total : int64; (* Total blocks. *)
- fs_is_swap : bool; (* If swap, following not valid. *)
- fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
- fs_blocks_avail : int64; (* Blocks free (available). *)
- fs_blocks_used : int64; (* Blocks in use. *)
- fs_inodes_total : int64; (* Total inodes. *)
- fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
- fs_inodes_avail : int64; (* Inodes free (available). *)
- fs_inodes_used : int64; (* Inodes in use. *)
-}
-
-(* Physical volumes. *)
-and pv = {
- lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *)
- pv_uuid : string; (* UUID. *)
-}
-
-(* Logical volumes. *)
-and lv = {
- lv_dev : device; (* Logical volume device. *)
-}
-
-and lvm_plugin_id = string
-
-(* Convert partition, filesystem types to printable strings for debugging. *)
-let string_of_partition
- { part_status = status; part_type = typ; part_dev = dev } =
- sprintf "%s: %s partition type %d"
- dev#name
- (match status with
- | Bootable -> "bootable"
- | Nonbootable -> "nonbootable"
- | Malformed -> "malformed"
- | NullEntry -> "empty")
- typ
-
-let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
- if not swap then name
- else name ^ " [swap]"
-
-(* Convert a UUID (containing '-' chars) to canonical form. *)
-let canonical_uuid uuid =
- let uuid' = String.make 32 ' ' in
- let j = ref 0 in
- for i = 0 to String.length uuid - 1 do
- if !j >= 32 then
- invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid);
- let c = uuid.[i] in
- if c <> '-' then ( uuid'.[!j] <- c; incr j )
- done;
- if !j <> 32 then
- invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid);
- uuid'
-
-(* Register a partition scheme. *)
-let partition_types = ref []
-let partition_type_register (parts_name : string) probe_fn =
- partition_types := (parts_name, probe_fn) :: !partition_types
-
-(* Probe a device for partitions. Returns [Some parts] or [None]. *)
-let probe_for_partitions dev =
- if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name;
- let rec loop = function
- | [] -> None
- | (parts_name, probe_fn) :: rest ->
- try Some (probe_fn dev)
- with Not_found -> loop rest
- in
- let r = loop !partition_types in
- if !debug then (
- match r with
- | None -> eprintf "no partitions found on %s\n%!" dev#name
- | Some { parts_name = name; parts = parts } ->
- eprintf "found %d %s partitions on %s:\n"
- (List.length parts) name dev#name;
- List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts
- );
- r
-
-(* Register a filesystem type (or swap). *)
-let filesystem_types = ref []
-let filesystem_type_register (fs_name : string) probe_fn =
- filesystem_types := (fs_name, probe_fn) :: !filesystem_types
-
-(* Probe a device for a filesystem. Returns [Some fs] or [None]. *)
-let probe_for_filesystem dev =
- if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name;
- let rec loop = function
- | [] -> None
- | (fs_name, probe_fn) :: rest ->
- try Some (probe_fn dev)
- with Not_found -> loop rest
- in
- let r = loop !filesystem_types in
- if !debug then (
- match r with
- | None -> eprintf "no filesystem found on %s\n%!" dev#name
- | Some fs ->
- eprintf "found a filesystem on %s:\n" dev#name;
- eprintf "\t%s\n%!" (string_of_filesystem fs)
- );
- r
-
-(* Register a volume management type. *)
-let lvm_types = ref []
-let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn =
- lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types
-
-(* Probe a device for a PV. Returns [Some lvm_name] or [None]. *)
-let probe_for_pv dev =
- if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name;
- let rec loop = function
- | [] -> None
- | (lvm_name, (probe_fn, _)) :: rest ->
- try Some (probe_fn lvm_name dev)
- with Not_found -> loop rest
- in
- let r = loop !lvm_types in
- if !debug then (
- match r with
- | None -> eprintf "no PV found on %s\n%!" dev#name
- | Some { lvm_plugin_id = name } ->
- eprintf "%s contains a %s PV\n%!" dev#name name
- );
- r
-
-let list_lvs lvm_name devs =
- let _, list_lvs_fn = List.assoc lvm_name !lvm_types in
- list_lvs_fn devs
-
-(*----------------------------------------------------------------------*)
-
-(* This version by Isaac Trotts. *)
-let group_by ?(cmp = Pervasives.compare) ls =
- let ls' =
- List.fold_left
- (fun acc (day1, x1) ->
- match acc with
- [] -> [day1, [x1]]
- | (day2, ls2) :: acctl ->
- if cmp day1 day2 = 0
- then (day1, x1 :: ls2) :: acctl
- else (day1, [x1]) :: acc)
- []
- ls
- in
- let ls' = List.rev ls' in
- List.map (fun (x, xs) -> x, List.rev xs) ls'
-
-let rec range a b =
- if a < b then a :: range (a+1) b
- else []
used throughout the plug-ins and main code.
*)
-val ( +* ) : int32 -> int32 -> int32
-val ( -* ) : int32 -> int32 -> int32
-val ( ** ) : int32 -> int32 -> int32
-val ( /* ) : int32 -> int32 -> int32
-val ( +^ ) : int64 -> int64 -> int64
-val ( -^ ) : int64 -> int64 -> int64
-val ( *^ ) : int64 -> int64 -> int64
-val ( /^ ) : int64 -> int64 -> int64
-(** int32 and int64 infix operators for convenience. *)
-
val debug : bool ref (** If true, emit debug info to stderr*)
val uri : string option ref (** Hypervisor/libvirt URI. *)
val inodes : bool ref (** Display inodes. *)
(** If virt_df_csv.ml is compiled in then this hook is overridden with
a function to write a single line to a CSV file.
*)
-
-(**
- {2 Domain/device model}
-
- The "domain/device model" that we currently understand looks
- like this:
-
-{v
-domains
- |
- \--- host partitions / disk image files
- ||
- guest block devices
- |
- +--> guest partitions (eg. using MBR)
- | |
- \-(1)->+--- filesystems (eg. ext3)
- |
- \--- PVs for LVM
- |||
- VGs and LVs
-v}
-
- (1) Filesystems and PVs may also appear directly on guest
- block devices.
-
- Partition schemes (eg. MBR) and filesystems register themselves
- with this main module and they are queried first to get an idea
- of the physical devices, partitions and filesystems potentially
- available to the guest.
-
- Volume management schemes (eg. LVM2) register themselves here
- and are called later with "spare" physical devices and partitions
- to see if they contain LVM data. If this results in additional
- logical volumes then these are checked for filesystems.
-
- Swap space is considered to be a dumb filesystem for the purposes
- of this discussion.
-*)
-
-class virtual device :
- object
- method virtual name : string
- method virtual read : int64 -> int -> string
- method read_bitstring : int64 -> int -> string * int * int
- method virtual size : int64
- end
- (**
- A virtual (or physical!) device, encapsulating any translation
- that has to be done to access the device. eg. For partitions
- there is a simple offset, but for LVM you may need complicated
- table lookups.
-
- We keep the underlying file descriptors open for the duration
- of the program. There aren't likely to be many of them, and
- the program is short-lived, and it's easier than trying to
- track which device is using what fd. As a result, there is no
- need for any close/deallocation function.
-
- Note the very rare use of OOP in OCaml!
- *)
-
-class block_device : string ->
- object
- method name : string
- method read : int64 -> int -> string
- method read_bitstring : int64 -> int -> string * int * int
- method size : int64
- end
- (** A concrete device which just direct-maps a file or /dev device. *)
-
-class offset_device : string -> int64 -> int64 -> device ->
- object
- method name : string
- method read : int64 -> int -> string
- method read_bitstring : int64 -> int -> string * int * int
- method size : int64
- end
- (** A concrete device which maps a linear part of an underlying device.
-
- [new offset_device name start size dev] creates a new
- device which maps bytes from [start] to [start+size-1]
- of the underlying device [dev] (ie. in this device they
- appear as bytes [0] to [size-1]).
-
- Useful for things like partitions.
- *)
-
-val null_device : device
- (** The null device. Any attempt to read generates an error. *)
-
-type domain = {
- dom_name : string; (** Domain name. *)
- dom_id : int option; (** Domain ID (if running). *)
- dom_disks : disk list; (** Domain disks. *)
- dom_lv_filesystems :
- (lv * filesystem) list; (** Domain LV filesystems. *)
-}
-and disk = {
- d_type : string option; (** The <disk type=...> *)
- d_device : string; (** The <disk device=...> (eg "disk") *)
- d_source : string; (** The <source file=... or dev> *)
- d_target : string; (** The <target dev=...> (eg "hda") *)
- d_dev : device; (** Disk device. *)
- d_content : disk_content; (** What's on it. *)
-}
-and disk_content =
- [ `Filesystem of filesystem (** Contains a direct filesystem. *)
- | `Partitions of partitions (** Contains partitions. *)
- | `PhysicalVolume of pv (** Contains an LVM PV. *)
- | `Unknown (** Not probed or unknown. *)
- ]
-and partitions = {
- parts_name : string; (** Name of partitioning scheme. *)
- parts : partition list; (** Partitions. *)
-}
-and partition = {
- part_status : partition_status; (** Bootable, etc. *)
- part_type : int; (** Partition filesystem type. *)
- part_dev : device; (** Partition device. *)
- part_content : partition_content; (** What's on it. *)
-}
-and partition_status = Bootable | Nonbootable | Malformed | NullEntry
-and partition_content =
- [ `Filesystem of filesystem (** Filesystem. *)
- | `PhysicalVolume of pv (** Contains an LVM PV. *)
- | `Unknown (** Not probed or unknown. *)
- ]
-and filesystem = {
- fs_name : string; (** Name of filesystem. *)
- fs_block_size : int64; (** Block size (bytes). *)
- fs_blocks_total : int64; (** Total blocks. *)
- fs_is_swap : bool; (** If swap, following not valid. *)
- fs_blocks_reserved : int64; (** Blocks reserved for super-user. *)
- fs_blocks_avail : int64; (** Blocks free (available). *)
- fs_blocks_used : int64; (** Blocks in use. *)
- fs_inodes_total : int64; (** Total inodes. *)
- fs_inodes_reserved : int64; (** Inodes reserved for super-user. *)
- fs_inodes_avail : int64; (** Inodes free (available). *)
- fs_inodes_used : int64; (** Inodes in use. *)
-}
-and pv = {
- lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected
- this. *)
- pv_uuid : string; (** UUID. *)
-}
-and lv = {
- lv_dev : device; (** Logical volume device. *)
-}
-
-and lvm_plugin_id
-
-val string_of_partition : partition -> string
-val string_of_filesystem : filesystem -> string
-(** Convert a partition or filesystem struct to a string (for debugging). *)
-
-val canonical_uuid : string -> string
-(** Convert a UUID which may contain '-' characters to canonical form. *)
-
-(** {2 Plug-in registration functions} *)
-
-val partition_type_register : string -> (device -> partitions) -> unit
-(** Register a partition probing plug-in. *)
-
-val probe_for_partitions : device -> partitions option
-(** Do a partition probe on a device. Returns [Some partitions] or [None]. *)
-
-val filesystem_type_register : string -> (device -> filesystem) -> unit
-(** Register a filesystem probing plug-in. *)
-
-val probe_for_filesystem : device -> filesystem option
-(** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *)
-
-val lvm_type_register :
- string -> (lvm_plugin_id -> device -> pv) -> (device list -> lv list) -> unit
-(** [lvm_type_register lvm_name probe_fn list_lvs_fn]
- registers a new LVM type. [probe_fn] is a function which
- should probe a device to find out if it contains a PV.
- [list_lvs_fn] is a function which should take a list of
- devices (PVs) and construct a list of LV devices.
-*)
-
-val probe_for_pv : device -> pv option
-(** Do a PV probe on a device. Returns [Some pv] or [None]. *)
-
-val list_lvs : lvm_plugin_id -> device list -> lv list
-(** Construct LV devices from a list of PVs. *)
-
-(** {2 Utility functions} *)
-
-val group_by : ?cmp:('a -> 'a -> int) -> ('a * 'b) list -> ('a * 'b list) list
-(** Group a sorted list of pairs by the first element of the pair. *)
-
-val range : int -> int -> int list
-(** [range a b] returns the list of integers [a <= i < b].
- If [a >= b] then the empty list is returned.
-*)
open Printf
-open Virt_df
+open Virt_df ;;
csv_write := Some (
fun chan row ->
open Virt_df_gettext.Gettext
open Virt_df
+let ( +* ) = Int32.add
+let ( -* ) = Int32.sub
+let ( ** ) = Int32.mul
+let ( /* ) = Int32.div
+
+let ( +^ ) = Int64.add
+let ( -^ ) = Int64.sub
+let ( *^ ) = Int64.mul
+let ( /^ ) = Int64.div
+
let () =
(* Command line argument parsing. *)
let set_uri = function "" -> uri := None | u -> uri := Some u in
"uri " ^ s_ "Connect to URI (default: Xen)";
"--csv", Arg.Set csv_mode,
" " ^ s_ "Write results in CSV format";
- "--debug", Arg.Set debug,
+ "--debug", Arg.Set Diskimage.debug,
" " ^ s_ "Debug mode (default: false)";
"-h", Arg.Set human,
" " ^ s_ "Print sizes in human-readable format";
csv_write stdout
in
- let doms : domain list =
+ (* name target dev_path *)
+ let doms : (string * (string * string) list) list =
if !test_files = [] then (
let xmls =
(* Connect to the hypervisor. *)
| Xml.Element ("domain", attrs, children) -> children, attrs
| _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in
- let domid =
+ (*let domid =
try Some (int_of_string (List.assoc "id" domain_attrs))
- with Not_found -> None in
+ with Not_found -> None in*)
let rec loop = function
| [] ->
List.filter_map (
function
| Xml.Element ("disk", attrs, children) ->
- let typ =
+ (*let typ =
try Some (List.assoc "type" attrs)
- with Not_found -> None in
+ with Not_found -> None in*)
let device =
try Some (List.assoc "device" attrs)
with Not_found -> None in
* source and target. Ignore CD-ROM devices.
*)
(match source, target, device with
- | _, _, Some "cdrom" -> None (* ignore *)
- | Some source, Some target, Some device ->
- (* Try to create a 'device' object for this
- * device. If it fails, print a warning
- * and ignore the device.
- *)
- (try
- let dev = new block_device source in
- Some {
- d_type = typ; d_device = device;
- d_source = source; d_target = target;
- d_dev = dev; d_content = `Unknown
- }
- with
- Unix.Unix_error (err, func, param) ->
- eprintf "%s:%s: %s" func param
- (Unix.error_message err);
- None
- )
+ | _, _, Some "cdrom" -> None (* ignore CD-ROMs *)
+ | Some source, Some target, _ -> Some (target, source)
| _ -> None (* ignore anything else *)
)
| _ -> None
) devices in
- { dom_name = name; dom_id = domid;
- dom_disks = disks; dom_lv_filesystems = [] }
+ name, disks
) xmls
) else (
(* In test mode (-t option) the user can pass one or more
*)
List.map (
fun filename ->
- {
- dom_name = filename; dom_id = None;
- dom_disks = [
- {
- d_type = Some "disk"; d_device = "disk";
- d_source = filename; d_target = "hda";
- d_dev = new block_device filename; d_content = `Unknown;
- }
- ];
- dom_lv_filesystems = []
- }
+ filename, ["hda", filename]
) !test_files
) in
- (* HOF to map over disks. *)
- let map_over_disks doms f =
- List.map (
- fun ({ dom_disks = disks } as dom) ->
- let disks = List.map f disks in
- { dom with dom_disks = disks }
- ) doms
- in
-
- (* 'doms' is our list of domains and their guest block devices, and
- * we've successfully opened each block device. Now probe them
- * to find out what they contain.
- *)
- let doms = map_over_disks doms (
- fun ({ d_dev = dev } as disk) ->
- (* See if it is partitioned first. *)
- let parts = probe_for_partitions dev in
- match parts with
- | Some parts ->
- { disk with d_content = `Partitions parts }
- | None ->
- (* Not partitioned. Does it contain a filesystem? *)
- let fs = probe_for_filesystem dev in
- match fs with
- | Some fs ->
- { disk with d_content = `Filesystem fs }
- | None ->
- (* Not partitioned, no filesystem, is it a PV? *)
- let pv = probe_for_pv dev in
- match pv with
- | Some lvm_name ->
- { disk with d_content = `PhysicalVolume lvm_name }
- | None ->
- disk (* Spare/unknown. *)
- ) in
-
- (* Now we have either detected partitions or a filesystem on each
- * physical device (or perhaps neither). See what is on those
- * partitions.
- *)
- let doms = map_over_disks doms (
- function
- | ({ d_dev = dev; d_content = `Partitions parts } as disk) ->
- let ps = List.map (
- fun p ->
- if p.part_status = Bootable || p.part_status = Nonbootable then (
- let fs = probe_for_filesystem p.part_dev in
- match fs with
- | Some fs ->
- { p with part_content = `Filesystem fs }
- | None ->
- (* Is it a PV? *)
- let pv = probe_for_pv p.part_dev in
- match pv with
- | Some lvm_name ->
- { p with part_content = `PhysicalVolume lvm_name }
- | None ->
- p (* Spare/unknown. *)
- ) else p
- ) parts.parts in
- let parts = { parts with parts = ps } in
- { disk with d_content = `Partitions parts }
- | disk -> disk
- ) in
-
- (* LVM filesystem detection
- *
- * For each domain, look for all disks/partitions which have been
- * identified as PVs and pass those back to the respective LVM
- * plugin for LV detection.
- *
- * (Note - a two-stage process because an LV can be spread over
- * several PVs, so we have to detect all PVs belonging to a
- * domain first).
- *
- * XXX To deal with RAID (ie. md devices) we will need to loop
- * around here because RAID is like LVM except that they normally
- * present as block devices which can be used by LVM.
- *)
- (* First: LV detection. *)
- let doms = List.map (
- fun ({ dom_disks = disks } as dom) ->
- (* Find all physical volumes, can be disks or partitions. *)
- let pvs_on_disks = List.filter_map (
- function
- | { d_dev = d_dev;
- d_content = `PhysicalVolume pv } -> Some (pv, d_dev)
- | _ -> None
- ) disks in
- let pvs_on_partitions = List.map (
- function
- | { d_content = `Partitions { parts = parts } } ->
- List.filter_map (
- function
- | { part_dev = part_dev;
- part_content = `PhysicalVolume pv } ->
- Some (pv, part_dev)
- | _ -> None
- ) parts
- | _ -> []
- ) disks in
- let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in
- dom, lvs
+ (* Convert these to Diskimage library 'machine's. *)
+ let machines = List.filter_map (
+ fun (name, disks) ->
+ try Some (Diskimage.open_machine name disks)
+ with Unix.Unix_error (err, func, param) ->
+ eprintf "%s:%s: %s" func param (Unix.error_message err);
+ None
) doms in
- (* Second: filesystem on LV detection. *)
- let doms = List.map (
- fun (dom, lvs) ->
- (* Group the LVs by plug-in type. *)
- let cmp (a,_) (b,_) = compare a b in
- let lvs = List.sort ~cmp lvs in
- let lvs = group_by lvs in
-
- let lvs =
- List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in
- let lvs = List.concat lvs in
-
- (* lvs is a list of potential LV devices. Now run them through the
- * probes to see if any contain filesystems.
- *)
- let filesystems =
- List.filter_map (
- fun ({ lv_dev = dev } as lv) ->
- match probe_for_filesystem dev with
- | Some fs -> Some (lv, fs)
- | None -> None
- ) lvs in
-
- { dom with dom_lv_filesystems = filesystems }
- ) doms in
+ (* Scan them. *)
+ let machines = List.map Diskimage.scan_machine machines in
(*----------------------------------------------------------------------*)
(* Now print the results. *)
in
(* HOF to iterate over filesystems. *)
- let iter_over_filesystems doms
- (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem ->
+ let iter_over_filesystems machines
+ (f : Diskimage.machine -> ?disk:Diskimage.disk -> ?partno:int ->
+ Diskimage.device -> Diskimage.filesystem ->
unit) =
List.iter (
- fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) ->
+ fun ({ Diskimage.m_disks = disks;
+ m_lv_filesystems = filesystems } as dom) ->
(* Ordinary filesystems found on disks & partitions. *)
List.iter (
function
- | ({ d_content = `Filesystem fs; d_dev = dev } as disk) ->
+ | ({ Diskimage.d_content = `Filesystem fs; d_dev = dev } as disk) ->
f dom ~disk dev fs
- | ({ d_content = `Partitions partitions } as disk) ->
+ | ({ Diskimage.d_content = `Partitions partitions } as disk) ->
List.iteri (
fun i ->
function
- | { part_content = `Filesystem fs; part_dev = dev } ->
+ | { Diskimage.part_content = `Filesystem fs;
+ part_dev = dev } ->
f dom ~disk ~partno:(i+1) dev fs
| _ -> ()
- ) partitions.parts
+ ) partitions.Diskimage.parts
| _ -> ()
) disks;
(* LV filesystems. *)
- List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems
- ) doms
+ List.iter (
+ fun ({Diskimage.lv_dev = dev}, fs) -> f dom dev fs
+ ) filesystems
+ ) machines
in
(* Printable name is like "domain:hda" or "domain:hda1". *)
- let printable_name dom ?disk ?partno dev =
- let dom_name = dom.dom_name in
+ let printable_name machine ?disk ?partno dev =
+ let m_name = machine.Diskimage.m_name in
(* Get the disk name (eg. "hda") from the domain XML, if
* we have it, otherwise use the device name (eg. for LVM).
*)
let disk_name =
match disk with
| None -> dev#name
- | Some disk -> disk.d_target
+ | Some disk -> disk.Diskimage.d_name
in
match partno with
| None ->
- dom_name ^ ":" ^ disk_name
+ m_name ^ ":" ^ disk_name
| Some partno ->
- dom_name ^ ":" ^ disk_name ^ string_of_int partno
+ m_name ^ ":" ^ disk_name ^ string_of_int partno
in
(* Print stats for each recognized filesystem. *)
- let print_stats dom ?disk ?partno dev fs =
- let name = printable_name dom ?disk ?partno dev in
+ let print_stats machine ?disk ?partno dev fs =
+ let name = printable_name machine ?disk ?partno dev in
printf "%-32s " name;
- if fs.fs_is_swap then (
+ let {
+ Diskimage.fs_name = fs_name;
+ fs_block_size = fs_block_size;
+ fs_blocks_total = fs_blocks_total;
+ fs_is_swap = fs_is_swap;
+ fs_blocks_reserved = fs_blocks_reserved;
+ fs_blocks_avail = fs_blocks_avail;
+ fs_blocks_used = fs_blocks_used;
+ fs_inodes_total = fs_inodes_total;
+ fs_inodes_reserved = fs_inodes_reserved;
+ fs_inodes_avail = fs_inodes_avail;
+ fs_inodes_used = fs_inodes_used
+ } = fs in
+
+ if fs_is_swap then (
(* Swap partition. *)
if not !human then
printf "%10Ld %s\n"
- (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name
+ (fs_block_size *^ fs_blocks_total /^ 1024L) fs_name
else
printf "%10s %s\n"
- (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name
+ (printable_size (fs_block_size *^ fs_blocks_total)) fs_name
) else (
(* Ordinary filesystem. *)
if not !inodes then ( (* Block display. *)
(* 'df' doesn't count the restricted blocks. *)
- let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
- let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
+ let blocks_total = fs_blocks_total -^ fs_blocks_reserved in
+ let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in
let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
if not !human then ( (* Display 1K blocks. *)
printf "%10Ld %10Ld %10Ld %s\n"
- (blocks_total *^ fs.fs_block_size /^ 1024L)
- (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L)
- (blocks_avail *^ fs.fs_block_size /^ 1024L)
- fs.fs_name
+ (blocks_total *^ fs_block_size /^ 1024L)
+ (fs_blocks_used *^ fs_block_size /^ 1024L)
+ (blocks_avail *^ fs_block_size /^ 1024L)
+ fs_name
) else ( (* Human-readable blocks. *)
printf "%10s %10s %10s %s\n"
- (printable_size (blocks_total *^ fs.fs_block_size))
- (printable_size (fs.fs_blocks_used *^ fs.fs_block_size))
- (printable_size (blocks_avail *^ fs.fs_block_size))
- fs.fs_name
+ (printable_size (blocks_total *^ fs_block_size))
+ (printable_size (fs_blocks_used *^ fs_block_size))
+ (printable_size (blocks_avail *^ fs_block_size))
+ fs_name
)
) else ( (* Inodes display. *)
printf "%10Ld %10Ld %10Ld %s\n"
- fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail
- fs.fs_name
+ fs_inodes_total fs_inodes_used fs_inodes_avail
+ fs_name
)
)
in
* We ignore the human-readable option because we assume that
* the data will be post-processed by something.
*)
- let print_stats_csv dom ?disk ?partno dev fs =
- let name = printable_name dom ?disk ?partno dev in
+ let print_stats_csv machine ?disk ?partno dev fs =
+ let name = printable_name machine ?disk ?partno dev in
+
+ let {
+ Diskimage.fs_name = fs_name;
+ fs_block_size = fs_block_size;
+ fs_blocks_total = fs_blocks_total;
+ fs_is_swap = fs_is_swap;
+ fs_blocks_reserved = fs_blocks_reserved;
+ fs_blocks_avail = fs_blocks_avail;
+ fs_blocks_used = fs_blocks_used;
+ fs_inodes_total = fs_inodes_total;
+ fs_inodes_reserved = fs_inodes_reserved;
+ fs_inodes_avail = fs_inodes_avail;
+ fs_inodes_used = fs_inodes_used
+ } = fs in
let row =
- if fs.fs_is_swap then
+ if fs_is_swap then
(* Swap partition. *)
- [ Int64.to_string (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L);
+ [ Int64.to_string (fs_block_size *^ fs_blocks_total /^ 1024L);
""; "" ]
else (
(* Ordinary filesystem. *)
if not !inodes then ( (* Block display. *)
(* 'df' doesn't count the restricted blocks. *)
- let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in
- let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in
+ let blocks_total = fs_blocks_total -^ fs_blocks_reserved in
+ let blocks_avail = fs_blocks_avail -^ fs_blocks_reserved in
let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in
- [ Int64.to_string (blocks_total *^ fs.fs_block_size /^ 1024L);
- Int64.to_string (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L);
- Int64.to_string (blocks_avail *^ fs.fs_block_size /^ 1024L) ]
+ [ Int64.to_string (blocks_total *^ fs_block_size /^ 1024L);
+ Int64.to_string (fs_blocks_used *^ fs_block_size /^ 1024L);
+ Int64.to_string (blocks_avail *^ fs_block_size /^ 1024L) ]
) else ( (* Inodes display. *)
- [ Int64.to_string fs.fs_inodes_total;
- Int64.to_string fs.fs_inodes_used;
- Int64.to_string fs.fs_inodes_avail ]
+ [ Int64.to_string fs_inodes_total;
+ Int64.to_string fs_inodes_used;
+ Int64.to_string fs_inodes_avail ]
)
) in
- let row = name :: row @ [fs.fs_name] in
+ let row = name :: row @ [fs_name] in
csv_write row
in
- iter_over_filesystems doms
+ iter_over_filesystems machines
(if not !csv_mode then print_stats else print_stats_csv)
git.annexia.org / virt-df.git / commitdiff