2 * Copyright (C) 2011 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License along
15 * with this program; if not, write to the Free Software Foundation, Inc.,
16 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
26 let () = Random.self_init ()
28 (* Command line argument parsing. *)
29 let prog = Filename.basename Sys.executable_name
31 let indisk, outdisk, convert, format, ignores, machine_readable, quiet,
33 let display_version () =
34 let g = new G.guestfs () in
35 let version = g#version () in
36 printf "virt-sparsify %Ld.%Ld.%Ld%s\n"
37 version.G.major version.G.minor version.G.release version.G.extra;
41 let add xs s = xs := s :: !xs in
43 let convert = ref "" in
44 let format = ref "" in
45 let ignores = ref [] in
46 let machine_readable = ref false in
47 let quiet = ref false in
48 let verbose = ref false in
49 let trace = ref false in
51 let argspec = Arg.align [
52 "--convert", Arg.Set_string convert, "format Format of output disk (default: same as input)";
53 "--format", Arg.Set_string format, "format Format of input disk";
54 "--ignore", Arg.String (add ignores), "fs Ignore filesystem";
55 "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
56 "-q", Arg.Set quiet, " Quiet output";
57 "--quiet", Arg.Set quiet, " -\"-";
58 "-v", Arg.Set verbose, " Enable debugging messages";
59 "--verbose", Arg.Set verbose, " -\"-";
60 "-V", Arg.Unit display_version, " Display version and exit";
61 "--version", Arg.Unit display_version, " -\"-";
62 "-x", Arg.Set trace, " Enable tracing of libguestfs calls";
65 let anon_fun s = disks := s :: !disks in
68 %s: sparsify a virtual machine disk
70 virt-sparsify [--options] indisk outdisk
72 A short summary of the options is given below. For detailed help please
73 read the man page virt-sparsify(1).
76 Arg.parse argspec anon_fun usage_msg;
78 (* Dereference the rest of the args. *)
79 let convert = match !convert with "" -> None | str -> Some str in
80 let format = match !format with "" -> None | str -> Some str in
81 let ignores = List.rev !ignores in
82 let machine_readable = !machine_readable in
84 let verbose = !verbose in
87 (* No arguments and machine-readable mode? Print out some facts
88 * about what this binary supports.
90 if !disks = [] && machine_readable then (
91 printf "virt-sparsify\n";
92 let g = new G.guestfs () in
93 g#add_drive_opts "/dev/null";
95 if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
97 if feature_available g [| "btrfs" |] then
102 (* Verify we got exactly 2 disks. *)
103 let indisk, outdisk =
104 match List.rev !disks with
105 | [indisk; outdisk] -> indisk, outdisk
107 error "usage is: %s [--options] indisk outdisk" prog in
109 (* The input disk must be an absolute path, so we can store the name
110 * in the overlay disk.
113 if not (Filename.is_relative indisk) then
116 Sys.getcwd () // indisk in
118 (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
120 try ignore (String.index indisk ','); true
121 with Not_found -> false in
122 if contains_comma then
123 error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
125 indisk, outdisk, convert, format, ignores, machine_readable, quiet,
130 printf "Create overlay file to protect source disk ...\n%!"
132 (* Create the temporary overlay file. *)
134 let tmp = Filename.temp_file "sparsify" ".qcow2" in
136 (* Unlink on exit. *)
137 at_exit (fun () -> try unlink tmp with _ -> ());
139 (* Create it with the indisk as the backing file. *)
141 sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
142 (Filename.quote indisk)
145 | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
146 (Filename.quote tmp) in
149 if Sys.command cmd <> 0 then
150 error "external command failed: %s" cmd;
156 printf "Examine source disk ...\n%!"
158 (* Connect to libguestfs. *)
160 let g = new G.guestfs () in
161 if trace then g#set_trace true;
162 if verbose then g#set_verbose true;
164 (* Note that the temporary overlay disk is always qcow2 format. *)
165 g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
167 if not quiet then Progress.set_up_progress_bar ~machine_readable g;
172 (* Get the size in bytes of the input disk. *)
173 let insize = g#blockdev_getsize64 "/dev/sda"
175 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
177 let filesystems = g#list_filesystems () in
178 let filesystems = List.map fst filesystems in
179 let filesystems = List.sort compare filesystems in
182 let fs = canonicalize fs in
183 List.exists (fun fs' -> fs = canonicalize fs') ignores
188 if not (is_ignored fs) then (
190 try g#mount_options "" fs "/"; true
195 printf "Fill free space in %s with zero ...\n%!" fs;
197 (* Choose a random filename, just letters and numbers, in
198 * 8.3 format. This ought to be compatible with any
199 * filesystem and not clash with existing files.
201 let filename = "/" ^ string_random8 () ^ ".tmp" in
203 (* This command is expected to fail. *)
204 (try g#dd "/dev/zero" filename with _ -> ());
206 (* Make sure the last part of the file is written to disk. *)
216 (* Fill unused space in volume groups. *)
218 let vgs = g#vgs () in
219 let vgs = Array.to_list vgs in
220 let vgs = List.sort compare vgs in
223 if not (List.mem vg ignores) then (
224 let lvname = string_random8 () in
225 let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
228 try g#lvcreate lvname vg 32; true
233 printf "Fill free space in volgroup %s with zero ...\n%!" vg;
235 (* XXX Don't have lvcreate -l 100%FREE. Fake it. *)
236 g#lvresize_free lvdev 100;
238 (* This command is expected to fail. *)
239 (try g#dd "/dev/zero" lvdev with _ -> ());
247 (* Don't need libguestfs now. *)
251 (* What should the output format be? If the user specified an
252 * input format, use that, else detect it from the source image.
256 | Some fmt -> fmt (* user specified output conversion *)
259 | Some fmt -> fmt (* user specified input format, use that *)
261 (* Don't know, so we must autodetect. *)
262 let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
263 let chan = open_process_in cmd in
264 let line = input_line chan in
265 let stat = close_process_in chan in
269 error "external command failed: %s" cmd
271 error "external command '%s' killed by signal %d" cmd i
273 error "external command '%s' stopped by signal %d" cmd i
275 if string_prefix line "QEMU QCOW Image (v2)" then
277 else if string_find line "VirtualBox" >= 0 then
280 "raw" (* XXX guess *)
282 (* Now run qemu-img convert which copies the overlay to the
283 * destination and automatically does sparsification.
287 printf "Copy to destination and make sparse ...\n%!";
290 sprintf "qemu-img convert -f qcow2 -O %s %s %s"
291 (Filename.quote output_format)
292 (Filename.quote overlaydisk) (Filename.quote outdisk) in
295 if Sys.command cmd <> 0 then
296 error "external command failed: %s" cmd
302 wrap "Sparsify operation completed with no errors. Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";