1 (* Diskimage library for reading disk images.
2 (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25 let ( +* ) = Int32.add
26 let ( -* ) = Int32.sub
27 let ( ** ) = Int32.mul
28 let ( /* ) = Int32.div
30 let ( +^ ) = Int64.add
31 let ( -^ ) = Int64.sub
32 let ( *^ ) = Int64.mul
33 let ( /^ ) = Int64.div
35 class virtual device =
37 method virtual read : int64 -> int -> string
38 method virtual size : int64
39 method virtual name : string
43 (* Helper method to read a chunk of data into a bitstring. *)
44 method read_bitstring offset len =
45 let str = self#read offset len in
49 (* A concrete device which just direct-maps a file or /dev device. *)
50 class block_device filename =
51 let fd = openfile filename [ O_RDONLY ] 0 in
52 let size = (LargeFile.fstat fd).LargeFile.st_size in
55 method read offset len =
56 ignore (LargeFile.lseek fd offset SEEK_SET);
57 let str = String.make len '\000' in
60 method close () = close fd
62 method name = filename
65 (* A linear offset/size from an underlying device. *)
66 class offset_device name start size (dev : device) =
71 (* method close () = dev#close () - NB: NO!! Device may be shared. *)
72 method read offset len =
73 if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then
75 sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)"
78 dev#read (start+^offset) len
81 (* The null device. Any attempt to read generates an error. *)
82 let null_device : device =
85 method read _ _ = assert false
91 m_name : string; (* Machine name. *)
92 m_disks : disk list; (* Machine disks. *)
94 (lv * filesystem) list; (* Machine LV filesystems. *)
97 d_name : string; (* Device name (eg "hda") *)
99 (* About the device itself. *)
100 d_dev : device; (* Disk device. *)
101 d_content : disk_content; (* What's on it. *)
104 [ `Unknown (* Not probed or unknown. *)
105 | `Partitions of partitions (* Contains partitions. *)
106 | `Filesystem of filesystem (* Contains a filesystem directly. *)
107 | `PhysicalVolume of pv (* Contains an LVM PV. *)
113 parts_name : string; (* Name of partitioning scheme. *)
114 parts : partition list (* Partitions. *)
117 part_status : partition_status; (* Bootable, etc. *)
118 part_type : int; (* Partition filesystem type. *)
119 part_dev : device; (* Partition device. *)
120 part_content : partition_content; (* What's on it. *)
122 and partition_status = Bootable | Nonbootable | Malformed | NullEntry
123 and partition_content =
124 [ `Unknown (* Not probed or unknown. *)
125 | `Filesystem of filesystem (* Filesystem. *)
126 | `PhysicalVolume of pv (* Contains an LVM PV. *)
129 (* Filesystems (also swap devices). *)
131 fs_name : string; (* Name of filesystem. *)
132 fs_block_size : int64; (* Block size (bytes). *)
133 fs_blocks_total : int64; (* Total blocks. *)
134 fs_is_swap : bool; (* If swap, following not valid. *)
135 fs_blocks_reserved : int64; (* Blocks reserved for super-user. *)
136 fs_blocks_avail : int64; (* Blocks free (available). *)
137 fs_blocks_used : int64; (* Blocks in use. *)
138 fs_inodes_total : int64; (* Total inodes. *)
139 fs_inodes_reserved : int64; (* Inodes reserved for super-user. *)
140 fs_inodes_avail : int64; (* Inodes free (available). *)
141 fs_inodes_used : int64; (* Inodes in use. *)
144 (* Physical volumes. *)
146 lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *)
147 pv_uuid : string; (* UUID. *)
150 (* Logical volumes. *)
152 lv_dev : device; (* Logical volume device. *)
155 and lvm_plugin_id = string
157 (* Convert partition, filesystem types to printable strings for debugging. *)
158 let string_of_partition
159 { part_status = status; part_type = typ; part_dev = dev } =
160 sprintf "%s: %s partition type %d"
163 | Bootable -> "bootable"
164 | Nonbootable -> "nonbootable"
165 | Malformed -> "malformed"
166 | NullEntry -> "empty")
169 let string_of_filesystem { fs_name = name; fs_is_swap = swap } =
170 if not swap then name
171 else name ^ " [swap]"
173 (* Convert a UUID (containing '-' chars) to canonical form. *)
174 let canonical_uuid uuid =
175 let uuid' = String.make 32 ' ' in
177 for i = 0 to String.length uuid - 1 do
178 if !j >= 32 then invalid_arg "canonical_uuid";
180 if c <> '-' then ( uuid'.[!j] <- c; incr j )
182 if !j <> 32 then invalid_arg "canonical_uuid";
185 (* This version by Isaac Trotts. *)
186 let group_by ?(cmp = Pervasives.compare) ls =
189 (fun acc (day1, x1) ->
192 | (day2, ls2) :: acctl ->
194 then (day1, x1 :: ls2) :: acctl
195 else (day1, [x1]) :: acc)
199 let ls' = List.rev ls' in
200 List.map (fun (x, xs) -> x, List.rev xs) ls'
203 if a < b then a :: range (a+1) b