From e6050cae9eee80791c3bb26f34c61f7dc89b142f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Thu, 1 Jan 1970 00:00:00 +0000 Subject: [PATCH] Complete rewrite of virt-df: - Uses pa_bitmatch for robust parsing of disk structures. - Completely modularized. --- virt-df/virt_df.ml | 941 ++++++++++++++++++++++++------------------ virt-df/virt_df_ext2.ml | 164 +++++--- virt-df/virt_df_linux_swap.ml | 46 ++- virt-df/virt_df_lvm2.ml | 15 +- virt-df/virt_df_main.ml | 3 + virt-df/virt_df_mbr.ml | 195 +++++++++ 6 files changed, 874 insertions(+), 490 deletions(-) mode change 100755 => 100644 virt-df/virt_df_main.ml create mode 100644 virt-df/virt_df_mbr.ml diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 4fbc706..b972837 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -25,51 +25,163 @@ open Virt_df_gettext.Gettext module C = Libvirt.Connect module D = Libvirt.Domain -module N = Libvirt.Network -(* Int64 operators for convenience. - * For sanity we do all int operations as int64's. - *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div +(* If set to true, then emit lots of debugging information. *) +let debug = true -let uri = ref None -let inodes = ref false -let human = ref false -let all = ref false +(* Int32 infix operators for convenience. *) +let ( +* ) = Int32.add +let ( -* ) = Int32.sub +let ( ** ) = Int32.mul +let ( /* ) = Int32.div -(* Maximum number of extended partitions possible. *) -let max_extended_partitions = 100 +(* Int64 infix operators for convenience. *) +let ( +^ ) = Int64.add +let ( -^ ) = Int64.sub +let ( *^ ) = Int64.mul +let ( /^ ) = Int64.div + +(* State of command line arguments. *) +let uri = ref None (* Hypervisor/libvirt URI. *) +let inodes = ref false (* Display inodes. *) +let human = ref false (* Display human-readable. *) +let all = ref false (* Show all/active domains. *) +let test_files = ref [] (* Used for test mode only. *) + +(*----------------------------------------------------------------------*) +(* The "domain/device model" that we currently understand looks + * like this: + * + * domains + * | + * \--- host partitions / disk image files + * || + * guest block devices + * | + * +--> guest partitions (eg. using MBR) + * | | + * \-(1)->+--- filesystems (eg. ext3) + * | + * \--- PVs for LVM + * ||| + * VGs and LVs + * + * (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. LVM) 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. + *) -let sector_size = 512L +(* 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 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 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 + +(* Domains and candidate guest block devices. *) -(* Parse out the device XML to get the names of disks. *) type domain = { dom_name : string; (* Domain name. *) dom_id : int option; (* Domain ID (if running). *) dom_disks : disk list; (* Domain disks. *) } and disk = { + (* From the XML ... *) d_type : string option; (* The *) - d_device : string option; (* The *) - d_source : string option; (* The *) - d_target : string option; (* The *) -} + d_device : string; (* The (eg "disk") *) + d_source : string; (* The *) + d_target : string; (* The (eg "hda") *) -type partition = { + (* 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 unit (* 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 type. *) - part_lba_start : int64; (* LBA start sector. *) - part_len : int64; (* Length in sectors. *) + 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 - -type filesystem_stats = { - fs_name : string; +and partition_content = + [ `Unknown (* Not probed or unknown. *) + | `Filesystem of filesystem (* Filesystem. *) + | `PhysicalVolume of unit (* 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. *) @@ -78,250 +190,80 @@ type filesystem_stats = { fs_inodes_avail : int64; (* Inodes free (available). *) fs_inodes_used : int64; (* Inodes in use. *) } -and swap_stats = { - swap_name : string; - swap_block_size : int64; (* Block size (bytes). *) - swap_blocks_total : int64; (* Total blocks. *) -} -and fs_probe_t = (* Return type of the probe_partition.*) - | Filesystem of filesystem_stats - | Swap of swap_stats - | ProbeFailed of string (* Probe failed for some reason. *) - | ProbeIgnore (* This filesystem should be ignored. *) - -(* Register a filesystem type. *) -let filesystems = Hashtbl.create 13 -let fs_register part_types probe_fn = - List.iter - (fun part_type -> Hashtbl.replace filesystems part_type probe_fn) - part_types - -(* Probe the devices and display. - * - dom_name is the domain name - * - target will be something like "hda" - * - source will be the name of a file or disk partition on the local machine - *) -let rec probe_device dom_name target source = - let fd = openfile source [ O_RDONLY ] 0 in - let size = (LargeFile.fstat fd).LargeFile.st_size in - let size = size /^ sector_size in (* Size in sectors. *) - - (*print_device dom_name target source size;*) - - let partitions = probe_mbr fd in - - if partitions <> [] then ( - let stats = - List.mapi ( - fun i part -> - if part.part_status = Bootable || - part.part_status = Nonbootable then ( - let pnum = i+1 in - let target = target ^ string_of_int pnum in - Some (target, - probe_partition target (Some part.part_type) - fd part.part_lba_start part.part_len) - ) - else - None - ) partitions in - let stats = List.filter_map (fun x -> x) stats in - print_stats dom_name stats - ) else (* Not an MBR, assume it's a single partition. *) - print_stats dom_name [target, probe_partition target None fd 0L size]; - - close fd - -(* Probe the master boot record (if it is one) and read the partitions. - * Returns [] if this is not an MBR. - * http://en.wikipedia.org/wiki/Master_boot_record - *) -and probe_mbr fd = - lseek fd 510 SEEK_SET; - let str = String.create 2 in - if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then - [] (* Not MBR *) - else ( - (* Read the partition table. *) - lseek fd 446 SEEK_SET; - let str = String.create 64 in - if read fd str 0 64 <> 64 then - failwith (s_ "error reading partition table") - else ( - (* Extract partitions from the data. *) - let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in - (* XXX validate partition extents compared to disk. *) - (* Read extended partition data. *) - let extendeds = List.map ( - function - | { part_type = 0x05 } as part -> - probe_extended_partition - max_extended_partitions fd part part.part_lba_start - | part -> [] - ) primaries in - let extendeds = List.concat extendeds in - primaries @ extendeds - ) - ) - -(* Probe an extended partition. *) -and probe_extended_partition max fd epart sect = - if max > 0 then ( - (* Offset of the first EBR. *) - let ebr_offs = sect *^ sector_size in - (* EBR Signature? *) - LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET; - let str = String.create 2 in - if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then - [] (* Not EBR *) - else ( - (* Read the extended partition table entries (just 2 of them). *) - LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET; - let str = String.create 32 in - if read fd str 0 32 <> 32 then - failwith (s_ "error reading extended partition") - else ( - (* Extract partitions from the data. *) - let part1, part2 = - match List.map (get_partition str) [ 0; 16 ] with - | [p1;p2] -> p1,p2 - | _ -> failwith (s_ "probe_extended_partition: internal error") in - (* First partition entry has offset to the start of this partition. *) - let part1 = { part1 with - part_lba_start = sect +^ part1.part_lba_start } in - (* Second partition entry is zeroes if end of list, otherwise points - * to the next partition. - *) - if part2.part_status = NullEntry then - [part1] - else - part1 :: probe_extended_partition - (max-1) fd epart (sect +^ part2.part_lba_start) - ) - ) - ) - else [] - -(* Get the partition data from str.[offs] - str.[offs+15] *) -and get_partition str offs = - let part_type = Char.code str.[offs+4] in - let part_lba_start = read_int32_le str (offs+8) in - let part_len = read_int32_le str (offs+12) in - - let part_status = - if part_type = 0 && part_lba_start = 0L && part_len = 0L then - NullEntry - else ( - let part_status = Char.code str.[offs] in - match part_status with - | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed - ) in - - { part_status = part_status; - part_type = part_type; - part_lba_start = part_lba_start; - part_len = part_len } - -(* Probe a single partition, which we assume contains either a - * filesystem or is a PV. - * - target will be something like "hda" or "hda1" - * - part_type will be the partition type if known, or None - * - fd is a file descriptor opened on the device - * - start & size are where we think the start and size of the - * partition is within the file descriptor (in SECTORS) - *) -and probe_partition target part_type fd start size = - match part_type with - | None -> - ProbeFailed (s_ "detection of unpartitioned devices not yet supported") - | Some 0x05 -> - ProbeIgnore (* Extended partition - ignore it. *) - | Some part_type -> - try - let probe_fn = Hashtbl.find filesystems part_type in - probe_fn target part_type fd start size - with - Not_found -> - ProbeFailed - (sprintf (f_ "unsupported partition type %02x") part_type) - -and print_stats dom_name statss = - List.iter ( - fun (target, fs_probe_t) -> - let dom_target = dom_name ^ ":" ^ target in - printf "%-20s " dom_target; - - match fs_probe_t with - (* Swap partition. *) - | Swap { swap_name = swap_name; - swap_block_size = block_size; - swap_blocks_total = blocks_total } -> - if not !human then - printf "%10Ld %s\n" - (block_size *^ blocks_total /^ 1024L) swap_name - else - printf "%10s %s\n" - (printable_size (block_size *^ blocks_total)) swap_name - (* Ordinary filesystem. *) - | Filesystem stats -> - if not !inodes then ( (* Block display. *) - (* 'df' doesn't count the restricted blocks. *) - let blocks_total = - stats.fs_blocks_total -^ stats.fs_blocks_reserved in - let blocks_avail = - stats.fs_blocks_avail -^ stats.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 *^ stats.fs_block_size /^ 1024L) - (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L) - (blocks_avail *^ stats.fs_block_size /^ 1024L) - stats.fs_name - ) else ( (* Human-readable blocks. *) - printf "%10s %10s %10s %s\n" - (printable_size (blocks_total *^ stats.fs_block_size)) - (printable_size (stats.fs_blocks_used *^ stats.fs_block_size)) - (printable_size (blocks_avail *^ stats.fs_block_size)) - stats.fs_name - ) - ) else ( (* Inodes display. *) - printf "%10Ld %10Ld %10Ld %s\n" - stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail - stats.fs_name - ) - - (* Unsupported filesystem or other failure. *) - | ProbeFailed reason -> - printf " %s\n" reason - - | ProbeIgnore -> () - ) statss - -(* Target is something like "hda" and size is the size in sectors. *) -and print_device dom_name target source size = - printf "%s /dev/%s (%s) %s\n" - dom_name target (printable_size (size *^ sector_size)) source - -and printable_size bytes = - if bytes < 1024L *^ 1024L then - sprintf "%Ld bytes" bytes - else if bytes < 1024L *^ 1024L *^ 1024L then - sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.) - else - sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.) - -and read_int32_le str offs = - Int64.of_int (Char.code str.[offs]) +^ - 256L *^ Int64.of_int (Char.code str.[offs+1]) +^ - 65536L *^ Int64.of_int (Char.code str.[offs+2]) +^ - 16777216L *^ Int64.of_int (Char.code str.[offs+3]) - -and read_int16_le str offs = - Int64.of_int (Char.code str.[offs]) +^ - 256L *^ Int64.of_int (Char.code str.[offs+1]) +(* 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]" + +(* 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 filesystems. Returns [Some fs] or [None]. *) +let probe_for_filesystems 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 = + lvm_types := (lvm_name, probe_fn) :: !lvm_types +*) + +(*----------------------------------------------------------------------*) let main () = (* Command line argument parsing. *) @@ -337,6 +279,10 @@ let main () = exit 0 in + let test_mode filename = + test_files := filename :: !test_files + in + let argspec = Arg.align [ "-a", Arg.Set all, " " ^ s_ "Show all domains (default: only active domains)"; @@ -354,6 +300,8 @@ let main () = " " ^ s_ "Show inodes instead of blocks"; "--inodes", Arg.Set inodes, " " ^ s_ "Show inodes instead of blocks"; + "-t", Arg.String test_mode, + "dev" ^ s_ "(Test mode) Display contents of block device or file"; "--version", Arg.Unit version, " " ^ s_ "Display version and exit"; ] in @@ -369,127 +317,230 @@ OPTIONS" in Arg.parse argspec anon_fun usage_msg; - let xmls = - (* Connect to the hypervisor. *) - let conn = - let name = !uri in - try C.connect_readonly ?name () - with - Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - (* If non-root and no explicit connection URI, print a warning. *) - if geteuid () <> 0 && name = None then ( - print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"); - ); - exit 1 in - - (* Get the list of active & inactive domains. *) - let doms = - let nr_active_doms = C.num_of_domains conn in - let active_doms = Array.to_list (C.list_domains conn nr_active_doms) in - let active_doms = List.map (D.lookup_by_id conn) active_doms in - if not !all then - active_doms - else ( - let nr_inactive_doms = C.num_of_defined_domains conn in - let inactive_doms = - Array.to_list (C.list_defined_domains conn nr_inactive_doms) in - let inactive_doms = List.map (D.lookup_by_name conn) inactive_doms in - active_doms @ inactive_doms - ) in - - (* Get their XML. *) - let xmls = List.map D.get_xml_desc doms in - - (* Parse the XML. *) - let xmls = List.map Xml.parse_string xmls in - - (* Return just the XML documents - everything else will be closed - * and freed including the connection to the hypervisor. - *) - xmls in - let doms : domain list = - (* Grr.. Need to use a library which has XPATH support (or cduce). *) - List.map ( - fun xml -> - let nodes, domain_attrs = - match xml with - | Xml.Element ("domain", attrs, children) -> children, attrs - | _ -> failwith (s_ "get_xml_desc didn't return ") in - - let domid = - try Some (int_of_string (List.assoc "id" domain_attrs)) - with Not_found -> None in - - let rec loop = function - | [] -> - failwith (s_ "get_xml_desc returned no node in XML") - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith (s_ "get_xml_desc returned strange node") - | _ :: rest -> loop rest - in - let name = loop nodes in - - let devices = + if !test_files = [] then ( + let xmls = + (* Connect to the hypervisor. *) + let conn = + let name = !uri in + try C.connect_readonly ?name () + with + Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + (* If non-root and no explicit connection URI, print a warning. *) + if geteuid () <> 0 && name = None then ( + print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"); + ); + exit 1 in + + (* Get the list of active & inactive domains. *) + let doms = + let nr_active_doms = C.num_of_domains conn in + let active_doms = + Array.to_list (C.list_domains conn nr_active_doms) in + let active_doms = + List.map (D.lookup_by_id conn) active_doms in + if not !all then + active_doms + else ( + let nr_inactive_doms = C.num_of_defined_domains conn in + let inactive_doms = + Array.to_list (C.list_defined_domains conn nr_inactive_doms) in + let inactive_doms = + List.map (D.lookup_by_name conn) inactive_doms in + active_doms @ inactive_doms + ) in + + (* Get their XML. *) + let xmls = List.map D.get_xml_desc doms in + + (* Parse the XML. *) + let xmls = List.map Xml.parse_string xmls in + + (* Return just the XML documents - everything else will be closed + * and freed including the connection to the hypervisor. + *) + xmls in + + (* Grr.. Need to use a library which has XPATH support (or cduce). *) + List.map ( + fun xml -> + let nodes, domain_attrs = + match xml with + | Xml.Element ("domain", attrs, children) -> children, attrs + | _ -> failwith (s_ "get_xml_desc didn't return ") in + + let domid = + try Some (int_of_string (List.assoc "id" domain_attrs)) + with Not_found -> None in + + let rec loop = function + | [] -> + failwith (s_ "get_xml_desc returned no node in XML") + | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name + | Xml.Element ("name", _, _) :: _ -> + failwith (s_ "get_xml_desc returned strange node") + | _ :: rest -> loop rest + in + let name = loop nodes in + let devices = + let devices = + List.filter_map ( + function + | Xml.Element ("devices", _, devices) -> Some devices + | _ -> None + ) nodes in + List.concat devices in + + let rec target_dev_of = function + | [] -> None + | Xml.Element ("target", attrs, _) :: rest -> + (try Some (List.assoc "dev" attrs) + with Not_found -> target_dev_of rest) + | _ :: rest -> target_dev_of rest + in + + let rec source_file_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "file" attrs) + with Not_found -> source_file_of rest) + | _ :: rest -> source_file_of rest + in + + let rec source_dev_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "dev" attrs) + with Not_found -> source_dev_of rest) + | _ :: rest -> source_dev_of rest + in + + let disks = List.filter_map ( function - | Xml.Element ("devices", _, devices) -> Some devices + | Xml.Element ("disk", attrs, children) -> + let typ = + try Some (List.assoc "type" attrs) + with Not_found -> None in + let device = + try Some (List.assoc "device" attrs) + with Not_found -> None in + let source = + match source_file_of children with + | (Some _) as source -> source + | None -> source_dev_of children in + let target = target_dev_of children in + + (* We only care about devices where we have + * 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_error (err, func, param) -> + eprintf "%s:%s: %s" func param (error_message err); + None + ) + | _ -> None (* ignore anything else *) + ) + | _ -> None - ) nodes in - List.concat devices in - - let rec target_dev_of = function - | [] -> None - | Xml.Element ("target", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> target_dev_of rest) - | _ :: rest -> target_dev_of rest - in - - let rec source_file_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "file" attrs) - with Not_found -> source_file_of rest) - | _ :: rest -> source_file_of rest - in - - let rec source_dev_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> source_dev_of rest) - | _ :: rest -> source_dev_of rest - in - - let disks = - List.filter_map ( - function - | Xml.Element ("disk", attrs, children) -> - let typ = - try Some (List.assoc "type" attrs) - with Not_found -> None in - let device = - try Some (List.assoc "device" attrs) - with Not_found -> None in - let source = - match source_file_of children with - | (Some _) as source -> source - | None -> source_dev_of children in - let target = target_dev_of children in - - Some { - d_type = typ; d_device = device; - d_source = source; d_target = target - } - | _ -> None - ) devices in - - { dom_name = name; dom_id = domid; dom_disks = disks } - ) xmls in + ) devices in + + { dom_name = name; dom_id = domid; dom_disks = disks } + ) xmls + ) else ( + (* In test mode (-t option) the user can pass one or more + * block devices or filenames (containing partitions/filesystems/etc) + * which we use for testing virt-df itself. We create fake domains + * from these. + *) + 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; + } + ] + } + ) !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_filesystems dev in + match fs with + | Some fs -> + { disk with d_content = `Filesystem fs } + | None -> + (* Not partitioned, no filesystem, so it's spare. *) + disk + ) 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_filesystems p.part_dev in + match fs with + | Some fs -> + { p with part_content = `Filesystem fs } + | None -> + p + ) else p + ) parts.parts in + let parts = { parts with parts = ps } in + { disk with d_content = `Partitions parts } + | disk -> disk + ) in + + (* XXX LVM stuff here. *) + + (* Print the title. *) let () = @@ -501,16 +552,108 @@ OPTIONS" in printf "%-20s %10s %10s %10s %s\n%!" (s_ "Filesystem") total used avail (s_ "Type") in - (* Probe the devices. *) - List.iter ( - fun { dom_name = dom_name; dom_disks = dom_disks } -> - List.iter ( - function - | { d_source = Some source; d_target = Some target } -> - probe_device dom_name target source - | { d_device = Some "cdrom" } -> - () (* Ignore physical CD-ROM devices. *) - | _ -> - print_endline (s_ "(device omitted)"); - ) dom_disks - ) doms + let printable_size bytes = + if bytes < 1024L *^ 1024L then + sprintf "%Ld bytes" bytes + else if bytes < 1024L *^ 1024L *^ 1024L then + sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.) + else + sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.) + in + + (* HOF to iterate over filesystems. *) + let iter_over_filesystems doms f = + List.iter ( + fun ({ dom_disks = disks } as dom) -> + List.iter ( + function + | ({ d_content = `Filesystem fs } as disk) -> + f dom disk None fs + | ({ d_content = `Partitions partitions } as disk) -> + List.iteri ( + fun i -> + function + | ({ part_content = `Filesystem fs } as part) -> + f dom disk (Some (part, i)) fs + | _ -> () + ) partitions.parts + | _ -> () + ) disks + ) doms + in + + (* Print stats for each recognized filesystem. *) + let print_stats dom disk part fs = + (* Printable name is like "domain:hda" or "domain:hda1". *) + let name = + let dom_name = dom.dom_name in + let d_target = disk.d_target in + match part with + | None -> + dom_name ^ ":" ^ d_target + | Some (_, pnum) -> + dom_name ^ ":" ^ d_target ^ string_of_int pnum in + printf "%-20s " name; + + if fs.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 + else + printf "%10s %s\n" + (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.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_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 + ) 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 + ) + ) else ( (* Inodes display. *) + printf "%10Ld %10Ld %10Ld %s\n" + fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail + fs.fs_name + ) + ) + in + iter_over_filesystems doms print_stats + +(* +(* Probe a single partition, which we assume contains either a + * filesystem or is a PV. + * - target will be something like "hda" or "hda1" + * - part_type will be the partition type if known, or None + * - fd is a file descriptor opened on the device + * - start & size are where we think the start and size of the + * partition is within the file descriptor (in SECTORS) + *) +and probe_partition target part_type fd start size = + match part_type with + | None -> + ProbeFailed (s_ "detection of unpartitioned devices not yet supported") + | Some 0x05 -> + ProbeIgnore (* Extended partition - ignore it. *) + | Some part_type -> + try + let probe_fn = Hashtbl.find filesystems part_type in + probe_fn target part_type fd start size + with + Not_found -> + ProbeFailed + (sprintf (f_ "unsupported partition type %02x") part_type) +*) diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml index 1acd855..0ea8a25 100644 --- a/virt-df/virt_df_ext2.ml +++ b/virt-df/virt_df_ext2.ml @@ -21,46 +21,82 @@ open Unix open Printf + open Virt_df_gettext.Gettext +open Virt_df + +let superblock_offset = 1024L + +let probe_ext2 (dev : device) = + (* Load the superblock. *) + let bits = dev#read_bitstring superblock_offset 1024 in + + (* The structure is straight from /usr/include/linux/ext3_fs.h *) + bitmatch bits with + | s_inodes_count : 32 : littleendian; (* Inodes count *) + s_blocks_count : 32 : littleendian; (* Blocks count *) + s_r_blocks_count : 32 : littleendian; (* Reserved blocks count *) + s_free_blocks_count : 32 : littleendian; (* Free blocks count *) + s_free_inodes_count : 32 : littleendian; (* Free inodes count *) + s_first_data_block : 32 : littleendian; (* First Data Block *) + s_log_block_size : 32 : littleendian; (* Block size *) + s_log_frag_size : 32 : littleendian; (* Fragment size *) + s_blocks_per_group : 32 : littleendian; (* # Blocks per group *) + s_frags_per_group : 32 : littleendian; (* # Fragments per group *) + s_inodes_per_group : 32 : littleendian; (* # Inodes per group *) + s_mtime : 32 : littleendian; (* Mount time *) + s_wtime : 32 : littleendian; (* Write time *) + s_mnt_count : 16 : littleendian; (* Mount count *) + s_max_mnt_count : 16 : littleendian; (* Maximal mount count *) + 0xef53 : 16 : littleendian; (* Magic signature *) + s_state : 16 : littleendian; (* File system state *) + s_errors : 16 : littleendian; (* Behaviour when detecting errors *) + s_minor_rev_level : 16 : littleendian; (* minor revision level *) + s_lastcheck : 32 : littleendian; (* time of last check *) + s_checkinterval : 32 : littleendian; (* max. time between checks *) + s_creator_os : 32 : littleendian; (* OS *) + s_rev_level : 32 : littleendian; (* Revision level *) + s_def_resuid : 16 : littleendian; (* Default uid for reserved blocks *) + s_def_resgid : 16 : littleendian; (* Default gid for reserved blocks *) + s_first_ino : 32 : littleendian; (* First non-reserved inode *) + s_inode_size : 16 : littleendian; (* size of inode structure *) + s_block_group_nr : 16 : littleendian; (* block group # of this superblock *) + s_feature_compat : 32 : littleendian; (* compatible feature set *) + s_feature_incompat : 32 : littleendian; (* incompatible feature set *) + s_feature_ro_compat : 32 : littleendian; (* readonly-compatible feature set *) + s_uuid : 128 : bitstring; (* 128-bit uuid for volume *) + s_volume_name : 128 : bitstring; (* volume name XXX string *) + s_last_mounted : 512 : bitstring; (* directory where last mounted XXX string *) + s_algorithm_usage_bitmap : 32 : littleendian; (* For compression *) + s_prealloc_blocks : 8; (* Nr of blocks to try to preallocate*) + s_prealloc_dir_blocks : 8; (* Nr to preallocate for dirs *) + s_reserved_gdt_blocks : 16 : littleendian; (* Per group desc for online growth *) + s_journal_uuid : 128 : bitstring; (* uuid of journal superblock *) + s_journal_inum : 32 : littleendian; (* inode number of journal file *) + s_journal_dev : 32 : littleendian; (* device number of journal file *) + s_last_orphan : 32 : littleendian; (* start of list of inodes to delete *) + s_hash_seed0 : 32 : littleendian; (* HTREE hash seed *) + s_hash_seed1 : 32 : littleendian; + s_hash_seed2 : 32 : littleendian; + s_hash_seed3 : 32 : littleendian; + s_def_hash_version : 8; (* Default hash version to use *) + s_reserved_char_pad : 8; + s_reserved_word_pad : 16 : littleendian; + s_default_mount_opts : 32 : littleendian; + s_first_meta_bg : 32 : littleendian; (* First metablock block group *) + s_reserved : 6080 : bitstring -> (* Padding to the end of the block *) -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let sector_size = Virt_df.sector_size -let read_int32_le = Virt_df.read_int32_le - -let probe_ext2 target part_type fd start size = - LargeFile.lseek fd ((start+^2L) *^ sector_size) SEEK_SET; - let str = String.create 128 in - if read fd str 0 128 <> 128 then - failwith (s_ "error reading ext2/ext3 magic") - else ( - if str.[56] != '\x53' || str.[57] != '\xEF' then ( - Virt_df.ProbeFailed (s_ "partition marked EXT2/3 but no valid filesystem") - ) else ( - (* Refer to *) - let s_inodes_count = read_int32_le str 0 in - let s_blocks_count = read_int32_le str 4 in - let s_r_blocks_count = read_int32_le str 8 in - let s_free_blocks_count = read_int32_le str 12 in - let s_free_inodes_count = read_int32_le str 16 in - let s_first_data_block = read_int32_le str 20 in - let s_log_block_size = read_int32_le str 24 in - (*let s_log_frag_size = read_int32_le str 28 in*) - let s_blocks_per_group = read_int32_le str 32 in - - (* Work out the block size in bytes. *) - let s_log_block_size = Int64.to_int s_log_block_size in - let block_size = 1024L in - let block_size = Int64.shift_left block_size s_log_block_size in - - (* Number of groups. *) - let s_groups_count = - (s_blocks_count -^ s_first_data_block -^ 1L) - /^ s_blocks_per_group +^ 1L in + (* Work out the block size in bytes. *) + let s_log_block_size = Int32.to_int s_log_block_size in + let block_size = 1024L in + let block_size = Int64.shift_left block_size s_log_block_size in + + (* Number of groups. *) + let s_groups_count = + Int64.of_int32 ( + (s_blocks_count -* s_first_data_block -* 1l) + /* s_blocks_per_group +* 1l + ) in (* (* Number of group descriptors per block. *) @@ -71,30 +107,32 @@ let probe_ext2 target part_type fd start size = /^ s_desc_per_block *) - (* Calculate the block overhead (used by superblocks, inodes, etc.) - * See fs/ext2/super.c. - *) - let overhead = s_first_data_block in - let overhead = (* XXX *) overhead in - - - Virt_df.Filesystem { - Virt_df.fs_name = s_ "Linux ext2/3"; - fs_block_size = block_size; - fs_blocks_total = s_blocks_count -^ overhead; - fs_blocks_reserved = s_r_blocks_count; - fs_blocks_avail = s_free_blocks_count; - fs_blocks_used = s_blocks_count -^ overhead -^ s_free_blocks_count; - fs_inodes_total = s_inodes_count; - fs_inodes_reserved = 0L; (* XXX? *) - fs_inodes_avail = s_free_inodes_count; - fs_inodes_used = s_inodes_count (*-^ 0L*) -^ s_free_inodes_count; - } - ) - ) + (* Calculate the block overhead (used by superblocks, inodes, etc.) + * See fs/ext2/super.c. + *) + let overhead = Int64.of_int32 s_first_data_block in + let overhead = (* XXX *) overhead in + + { + fs_name = s_ "Linux ext2/3"; + fs_block_size = block_size; + fs_blocks_total = Int64.of_int32 s_blocks_count -^ overhead; + fs_is_swap = false; + fs_blocks_reserved = Int64.of_int32 s_r_blocks_count; + fs_blocks_avail = Int64.of_int32 s_free_blocks_count; + fs_blocks_used = + Int64.of_int32 s_blocks_count -^ overhead + -^ Int64.of_int32 s_free_blocks_count; + fs_inodes_total = Int64.of_int32 s_inodes_count; + fs_inodes_reserved = 0L; (* XXX? *) + fs_inodes_avail = Int64.of_int32 s_free_inodes_count; + fs_inodes_used = Int64.of_int32 s_inodes_count + (*-^ 0L*) + -^ Int64.of_int32 s_free_inodes_count; + } + + | _ -> + raise Not_found (* Not an EXT2/3 superblock. *) (* Register with main code. *) -let () = - Virt_df.fs_register - [ 0x83 ] (* Partition type. *) - probe_ext2 +let () = filesystem_type_register "ext2" probe_ext2 diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml index 04e22b9..ad56149 100644 --- a/virt-df/virt_df_linux_swap.ml +++ b/virt-df/virt_df_linux_swap.ml @@ -21,22 +21,34 @@ *) open Virt_df_gettext.Gettext - -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let probe_swap target part_type fd start size = - Virt_df.Swap { - Virt_df.swap_name = s_ "Linux swap"; - swap_block_size = 4096L; (* XXX *) - swap_blocks_total = size *^ 512L /^ 4096L; - } +open Virt_df + +let probe_swap (dev : device) = + (* Load the "superblock" (ie. first 0x1000 bytes). *) + let bits = dev#read_bitstring 0L 0x1000 in + + bitmatch bits with + (* Actually this isn't just padding. *) + | padding : 8*0x1000 - 10*8 : bitstring; + magic : 10*8 : bitstring + when Bitmatch.string_of_bitstring magic = "SWAPSPACE2" -> + { + fs_name = s_ "Linux swap"; + fs_block_size = 4096L; (* XXX *) + fs_blocks_total = dev#size /^ 4096L; + + (* The remaining fields are ignored when fs_is_swap is true. *) + fs_is_swap = true; + fs_blocks_reserved = 0L; + fs_blocks_avail = 0L; + fs_blocks_used = 0L; + fs_inodes_total = 0L; + fs_inodes_reserved = 0L; + fs_inodes_avail = 0L; + fs_inodes_used = 0L; + } + | _ -> + raise Not_found (* Not Linux swapspace. *) (* Register with main code. *) -let () = - Virt_df.fs_register - [ 0x82 ] (* Partition type. *) - probe_swap +let () = filesystem_type_register "linux_swap" probe_swap diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index d01a5a8..a79ec7f 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -22,18 +22,11 @@ open Printf open Virt_df_gettext.Gettext +open Virt_df -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let probe_lvm2 target part_type fd start size = - Virt_df.ProbeFailed (s_ "LVM2 not supported yet") +let probe_lvm2 (dev : device) = + raise Not_found (* Register with main code. *) let () = - Virt_df.fs_register - [ 0x8e ] (* Partition type. *) - probe_lvm2 + filesystem_type_register "LVM2" probe_lvm2 diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml old mode 100755 new mode 100644 index bc4096b..1359b28 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -17,4 +17,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* We just need this so that the filesystem modules get a chance to + * register themselves before we run the main program. + *) let () = Virt_df.main () diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml new file mode 100644 index 0000000..b9a6cb7 --- /dev/null +++ b/virt-df/virt_df_mbr.ml @@ -0,0 +1,195 @@ +(* 'df' command for virtual domains. + + (C) Copyright 2007 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. + + Support for Master Boot Record partition scheme. +*) + +open Printf +open Unix +open ExtList + +open Virt_df_gettext.Gettext +open Virt_df + +let sector_size = 512 +let sector_size64 = 512L + +(* Maximum number of extended partitions possible. *) +let max_extended_partitions = 100 + +(* Device representing a single partition. It just acts as an offset + * into the underlying device. + * + * Notes: + * (1) 'start'/'size' are measured in sectors. + * (2) 'partno' is the partition number, starting at 1 + * (cf. /dev/hda1 is the first partition). + * (3) 'dev' is the underlying block device. + *) +class partition_device dev partno start size = + let devname = dev#name in + let name = sprintf "%s%d" devname partno in + let start = start *^ sector_size64 in + let size = size *^ sector_size64 in +object (self) + 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 partition boundaries (%Ld/%d/%Ld)" + name offset len size + ); + dev#read (start+^offset) len +end + +(** Probe the + {{:http://en.wikipedia.org/wiki/Master_boot_record}master boot record} + (if it is one) and read the partitions. + + @raise Not_found if it is not an MBR. + *) +let rec probe_mbr (dev : device) = + (* Adjust size to sectors. *) + let size = dev#size /^ sector_size64 in + + (* Read the first sector. *) + let bits = + try dev#read_bitstring 0L sector_size + with exn -> raise Not_found in + + (* Does this match a likely-looking MBR? *) + bitmatch bits with + | padding : 3568 : bitstring; (* padding to byte offset 446 *) + part0 : 128 : bitstring; (* partitions *) + part1 : 128 : bitstring; + part2 : 128 : bitstring; + part3 : 128 : bitstring; + 0x55 : 8; 0xAA : 8 -> (* MBR signature *) + + (* Parse the partition table entries. *) + let primaries = + List.mapi (parse_mbr_entry dev) [part0;part1;part2;part3] in + +(* + (* Read extended partition data. *) + let extendeds = List.map ( + function + | { part_type = 0x05 } as part -> + probe_extended_partition + max_extended_partitions fd part part.part_lba_start + | part -> [] + ) primaries in + let extendeds = List.concat extendeds in + primaries @ extendeds +*) + { parts_name = "MBR"; parts = primaries } + + | _ -> + raise Not_found (* not an MBR *) + +(* Parse a single partition table entry. See the table here: + * http://en.wikipedia.org/wiki/Master_boot_record + *) +and parse_mbr_entry dev i bits = + bitmatch bits with + | 0l : 32; 0l : 32; 0l : 32; 0l : 32 -> + { part_status = NullEntry; part_type = 0; + part_dev = null_device; part_content = `Unknown } + + | 0 : 8; first_chs : 24; + part_type : 8; last_chs : 24; + first_lba : 32 : unsigned, littleendian; + part_size : 32 : unsigned, littleendian -> + make_mbr_entry Nonbootable dev (i+1) part_type first_lba part_size + + | 0x80 : 8; first_chs : 24; + part_type : 8; last_chs : 24; + first_lba : 32 : unsigned, littleendian; + part_size : 32 : unsigned, littleendian -> + make_mbr_entry Bootable dev (i+1) part_type first_lba part_size + + | _ -> + { part_status = Malformed; part_type = 0; + part_dev = null_device; part_content = `Unknown } + +and make_mbr_entry part_status dev partno part_type first_lba part_size = + let first_lba = uint64_of_int32 first_lba in + let part_size = uint64_of_int32 part_size in + eprintf "first_lba = %Lx\n" first_lba; + eprintf "part_size = %Lx\n" part_size; + { part_status = part_status; + part_type = part_type; + part_dev = new partition_device dev partno first_lba part_size; + part_content = `Unknown } + +(* +This code worked previously, but now needs some love ... +XXX + +(* Probe an extended partition. *) +and probe_extended_partition max fd epart sect = + if max > 0 then ( + (* Offset of the first EBR. *) + let ebr_offs = sect *^ sector_size in + (* EBR Signature? *) + LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET; + let str = String.create 2 in + if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then + [] (* Not EBR *) + else ( + (* Read the extended partition table entries (just 2 of them). *) + LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET; + let str = String.create 32 in + if read fd str 0 32 <> 32 then + failwith (s_ "error reading extended partition") + else ( + (* Extract partitions from the data. *) + let part1, part2 = + match List.map (get_partition str) [ 0; 16 ] with + | [p1;p2] -> p1,p2 + | _ -> failwith (s_ "probe_extended_partition: internal error") in + (* First partition entry has offset to the start of this partition. *) + let part1 = { part1 with + part_lba_start = sect +^ part1.part_lba_start } in + (* Second partition entry is zeroes if end of list, otherwise points + * to the next partition. + *) + if part2.part_status = NullEntry then + [part1] + else + part1 :: probe_extended_partition + (max-1) fd epart (sect +^ part2.part_lba_start) + ) + ) + ) + else [] +*) + +(* Ugh, fake a UInt32 -> UInt64 conversion without sign extension, until + * we get working UInt32/UInt64 modules in extlib. + *) +and uint64_of_int32 u32 = + 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 -- 1.8.3.1