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, debug_gc,
32 format, ignores, machine_readable, quiet,
34 let display_version () =
35 let g = new G.guestfs () in
36 let version = g#version () in
37 printf "virt-sparsify %Ld.%Ld.%Ld%s\n"
38 version.G.major version.G.minor version.G.release version.G.extra;
42 let add xs s = xs := s :: !xs in
44 let convert = ref "" in
45 let debug_gc = ref false in
46 let format = ref "" in
47 let ignores = ref [] in
48 let machine_readable = ref false in
49 let quiet = ref false in
50 let verbose = ref false in
51 let trace = ref false in
53 let argspec = Arg.align [
54 "--convert", Arg.Set_string convert, "format Format of output disk (default: same as input)";
55 "--debug-gc", Arg.Set debug_gc, " Debug GC and memory allocations";
56 "--format", Arg.Set_string format, "format Format of input disk";
57 "--ignore", Arg.String (add ignores), "fs Ignore filesystem";
58 "--machine-readable", Arg.Set machine_readable, " Make output machine readable";
59 "-q", Arg.Set quiet, " Quiet output";
60 "--quiet", Arg.Set quiet, " -\"-";
61 "-v", Arg.Set verbose, " Enable debugging messages";
62 "--verbose", Arg.Set verbose, " -\"-";
63 "-V", Arg.Unit display_version, " Display version and exit";
64 "--version", Arg.Unit display_version, " -\"-";
65 "-x", Arg.Set trace, " Enable tracing of libguestfs calls";
68 let anon_fun s = disks := s :: !disks in
71 %s: sparsify a virtual machine disk
73 virt-sparsify [--options] indisk outdisk
75 A short summary of the options is given below. For detailed help please
76 read the man page virt-sparsify(1).
79 Arg.parse argspec anon_fun usage_msg;
81 (* Dereference the rest of the args. *)
82 let convert = match !convert with "" -> None | str -> Some str in
83 let debug_gc = !debug_gc in
84 let format = match !format with "" -> None | str -> Some str in
85 let ignores = List.rev !ignores in
86 let machine_readable = !machine_readable in
88 let verbose = !verbose in
91 (* No arguments and machine-readable mode? Print out some facts
92 * about what this binary supports.
94 if !disks = [] && machine_readable then (
95 printf "virt-sparsify\n";
96 let g = new G.guestfs () in
97 g#add_drive_opts "/dev/null";
99 if feature_available g [| "ntfsprogs"; "ntfs3g" |] then
101 if feature_available g [| "btrfs" |] then
106 (* Verify we got exactly 2 disks. *)
107 let indisk, outdisk =
108 match List.rev !disks with
109 | [indisk; outdisk] -> indisk, outdisk
111 error "usage is: %s [--options] indisk outdisk" prog in
113 (* The input disk must be an absolute path, so we can store the name
114 * in the overlay disk.
117 if not (Filename.is_relative indisk) then
120 Sys.getcwd () // indisk in
122 (* Check indisk filename doesn't contain a comma (limitation of qemu-img). *)
124 try ignore (String.index indisk ','); true
125 with Not_found -> false in
126 if contains_comma then
127 error "input filename '%s' contains a comma; qemu-img command line syntax prevents us from using such an image" indisk;
129 indisk, outdisk, convert,
130 debug_gc, format, ignores, machine_readable, quiet,
135 printf "Create overlay file to protect source disk ...\n%!"
137 (* Create the temporary overlay file. *)
139 let tmp = Filename.temp_file "sparsify" ".qcow2" in
141 (* Unlink on exit. *)
142 at_exit (fun () -> try unlink tmp with _ -> ());
144 (* Create it with the indisk as the backing file. *)
146 sprintf "qemu-img create -f qcow2 -o backing_file=%s%s %s > /dev/null"
147 (Filename.quote indisk)
150 | Some fmt -> sprintf ",backing_fmt=%s" (Filename.quote fmt))
151 (Filename.quote tmp) in
154 if Sys.command cmd <> 0 then
155 error "external command failed: %s" cmd;
161 printf "Examine source disk ...\n%!"
163 (* Connect to libguestfs. *)
165 let g = new G.guestfs () in
166 if trace then g#set_trace true;
167 if verbose then g#set_verbose true;
169 (* Note that the temporary overlay disk is always qcow2 format. *)
170 g#add_drive_opts ~format:"qcow2" ~readonly:false overlaydisk;
172 if not quiet then Progress.set_up_progress_bar ~machine_readable g;
177 (* Get the size in bytes of the input disk. *)
178 let insize = g#blockdev_getsize64 "/dev/sda"
180 (* Write zeroes for non-ignored filesystems that we are able to mount. *)
182 let filesystems = g#list_filesystems () in
183 let filesystems = List.map fst filesystems in
184 let filesystems = List.sort compare filesystems in
187 let fs = canonicalize fs in
188 List.exists (fun fs' -> fs = canonicalize fs') ignores
193 if not (is_ignored fs) then (
195 try g#mount_options "" fs "/"; true
200 printf "Fill free space in %s with zero ...\n%!" fs;
202 (* Choose a random filename, just letters and numbers, in
203 * 8.3 format. This ought to be compatible with any
204 * filesystem and not clash with existing files.
206 let filename = "/" ^ string_random8 () ^ ".tmp" in
208 (* This command is expected to fail. *)
209 (try g#dd "/dev/zero" filename with _ -> ());
211 (* Make sure the last part of the file is written to disk. *)
221 (* Fill unused space in volume groups. *)
223 let vgs = g#vgs () in
224 let vgs = Array.to_list vgs in
225 let vgs = List.sort compare vgs in
228 if not (List.mem vg ignores) then (
229 let lvname = string_random8 () in
230 let lvdev = "/dev/" ^ vg ^ "/" ^ lvname in
233 try g#lvcreate lvname vg 32; true
238 printf "Fill free space in volgroup %s with zero ...\n%!" vg;
240 (* XXX Don't have lvcreate -l 100%FREE. Fake it. *)
241 g#lvresize_free lvdev 100;
243 (* This command is expected to fail. *)
244 (try g#dd "/dev/zero" lvdev with _ -> ());
252 (* Don't need libguestfs now. *)
256 (* What should the output format be? If the user specified an
257 * input format, use that, else detect it from the source image.
261 | Some fmt -> fmt (* user specified output conversion *)
264 | Some fmt -> fmt (* user specified input format, use that *)
266 (* Don't know, so we must autodetect. *)
267 let cmd = sprintf "file -bsL %s" (Filename.quote indisk) in
268 let chan = open_process_in cmd in
269 let line = input_line chan in
270 let stat = close_process_in chan in
274 error "external command failed: %s" cmd
276 error "external command '%s' killed by signal %d" cmd i
278 error "external command '%s' stopped by signal %d" cmd i
280 if string_prefix line "QEMU QCOW Image (v2)" then
282 else if string_find line "VirtualBox" >= 0 then
285 "raw" (* XXX guess *)
287 (* Now run qemu-img convert which copies the overlay to the
288 * destination and automatically does sparsification.
292 printf "Copy to destination and make sparse ...\n%!";
295 sprintf "qemu-img convert -f qcow2 -O %s %s %s"
296 (Filename.quote output_format)
297 (Filename.quote overlaydisk) (Filename.quote outdisk) in
300 if Sys.command cmd <> 0 then
301 error "external command failed: %s" cmd
307 wrap "Sparsify operation completed with no errors. Before deleting the old disk, carefully check that the target disk boots and works correctly.\n";