[Libguestfs] [PATCH 1/2] common/mlstdutils: Add with_open_in and with_open_out functions.
Richard W.M. Jones
rjones at redhat.com
Sun Nov 5 19:42:40 UTC 2017
These safe wrappers around Pervasives.open_in and Pervasives.open_out
ensure that exceptions escaping cannot leave unclosed files.
---
common/mlstdutils/std_utils.ml | 39 ++++++++++++++++++++--------------
common/mlstdutils/std_utils.mli | 12 +++++++++++
common/mltools/tools_utils.ml | 39 +++++++++++++++++-----------------
dib/dib.ml | 9 ++++----
generator/bindtests.ml | 26 ++++++++++++-----------
generator/utils.ml | 14 ++++---------
v2v/changeuid.ml | 7 +------
v2v/copy_to_local.ml | 4 +---
v2v/input_libvirt_vddk.ml | 9 ++++----
v2v/input_ova.ml | 46 +++++++++++++++++++++--------------------
v2v/output_local.ml | 4 +---
v2v/output_qemu.ml | 29 +++++++++++++-------------
v2v/output_vdsm.ml | 8 ++-----
13 files changed, 127 insertions(+), 119 deletions(-)
diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index ba23f39ed..ee6bea5af 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -654,20 +654,29 @@ let verbose = ref false
let set_verbose () = verbose := true
let verbose () = !verbose
+let with_open_in filename f =
+ let chan = open_in filename in
+ protect ~f:(fun () -> f chan) ~finally:(fun () -> close_in chan)
+
+let with_open_out filename f =
+ let chan = open_out filename in
+ protect ~f:(fun () -> f chan) ~finally:(fun () -> close_out chan)
+
let read_whole_file path =
let buf = Buffer.create 16384 in
- let chan = open_in path in
- let maxlen = 16384 in
- let b = Bytes.create maxlen in
- let rec loop () =
- let r = input chan b 0 maxlen in
- if r > 0 then (
- Buffer.add_substring buf (Bytes.to_string b) 0 r;
+ with_open_in path (
+ fun chan ->
+ let maxlen = 16384 in
+ let b = Bytes.create maxlen in
+ let rec loop () =
+ let r = input chan b 0 maxlen in
+ if r > 0 then (
+ Buffer.add_substring buf (Bytes.to_string b) 0 r;
+ loop ()
+ )
+ in
loop ()
- )
- in
- loop ();
- close_in chan;
+ );
Buffer.contents buf
(* Compare two version strings intelligently. *)
@@ -824,10 +833,10 @@ let last_part_of str sep =
with Not_found -> None
let read_first_line_from_file filename =
- let chan = open_in filename in
- let line = try input_line chan with End_of_file -> "" in
- close_in chan;
- line
+ with_open_in filename (
+ fun chan ->
+ try input_line chan with End_of_file -> ""
+ )
let is_regular_file path = (* NB: follows symlinks. *)
try (Unix.stat path).Unix.st_kind = Unix.S_REG
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index 96c55a511..7af6c2111 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -387,6 +387,18 @@ val verbose : unit -> bool
(** Stores the colours ([--colours]), quiet ([--quiet]), trace ([-x])
and verbose ([-v]) flags in global variables. *)
+val with_open_in : string -> (in_channel -> 'a) -> 'a
+(** [with_open_in filename f] calls function [f] with [filename]
+ open for input. The file is always closed either on normal
+ return or if the function [f] throws an exception, so this is
+ both safer and more concise than the regular function. *)
+
+val with_open_out : string -> (out_channel -> 'a) -> 'a
+(** [with_open_out filename f] calls function [f] with [filename]
+ open for output. The file is always closed either on normal
+ return or if the function [f] throws an exception, so this is
+ both safer and more concise than the regular function. *)
+
val read_whole_file : string -> string
(** Read in the whole file as a string. *)
diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
index 8140ba84d..95658a75f 100644
--- a/common/mltools/tools_utils.ml
+++ b/common/mltools/tools_utils.ml
@@ -478,26 +478,25 @@ let debug_augeas_errors g =
(* Detect type of a file. *)
let detect_file_type filename =
- let chan = open_in filename in
- let get start size =
- try
- seek_in chan start;
- let b = Bytes.create size in
- really_input chan b 0 size;
- Some (Bytes.to_string b)
- with End_of_file | Invalid_argument _ -> None
- in
- let ret =
- if get 0 6 = Some "\2537zXZ\000" then `XZ
- else if get 0 4 = Some "PK\003\004" then `Zip
- else if get 0 4 = Some "PK\005\006" then `Zip
- else if get 0 4 = Some "PK\007\008" then `Zip
- else if get 257 6 = Some "ustar\000" then `Tar
- else if get 257 8 = Some "ustar\x20\x20\000" then `Tar
- else if get 0 2 = Some "\x1f\x8b" then `GZip
- else `Unknown in
- close_in chan;
- ret
+ with_open_in filename (
+ fun chan ->
+ let get start size =
+ try
+ seek_in chan start;
+ let b = Bytes.create size in
+ really_input chan b 0 size;
+ Some (Bytes.to_string b)
+ with End_of_file | Invalid_argument _ -> None
+ in
+ if get 0 6 = Some "\2537zXZ\000" then `XZ
+ else if get 0 4 = Some "PK\003\004" then `Zip
+ else if get 0 4 = Some "PK\005\006" then `Zip
+ else if get 0 4 = Some "PK\007\008" then `Zip
+ else if get 257 6 = Some "ustar\000" then `Tar
+ else if get 257 8 = Some "ustar\x20\x20\000" then `Tar
+ else if get 0 2 = Some "\x1f\x8b" then `GZip
+ else `Unknown
+ )
let is_partition dev =
try
diff --git a/dib/dib.ml b/dib/dib.ml
index 9a8d86bd9..94ad3003a 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -60,10 +60,11 @@ let read_dib_envvars () =
String.concat "" vars
let write_script fn text =
- let oc = open_out fn in
- output_string oc text;
- flush oc;
- close_out oc;
+ with_open_out fn (
+ fun oc ->
+ output_string oc text;
+ flush oc
+ );
Unix.chmod fn 0o755
let envvars_string l =
diff --git a/generator/bindtests.ml b/generator/bindtests.ml
index 4bdff8092..79b020326 100644
--- a/generator/bindtests.ml
+++ b/generator/bindtests.ml
@@ -966,18 +966,20 @@ and generate_php_bindtests () =
pr "--EXPECT--\n";
let dump filename =
- let chan = open_in filename in
- let rec loop () =
- let line = input_line chan in
- (match String.nsplit ":" line with
- | ("obool"|"oint"|"oint64"|"ostring"|"ostringlist") as x :: _ ->
- pr "%s: unset\n" x
- | _ -> pr "%s\n" line
- );
- loop ()
- in
- (try loop () with End_of_file -> ());
- close_in chan in
+ with_open_in filename (
+ fun chan ->
+ let rec loop () =
+ let line = input_line chan in
+ (match String.nsplit ":" line with
+ | ("obool"|"oint"|"oint64"|"ostring"|"ostringlist") as x :: _ ->
+ pr "%s: unset\n" x
+ | _ -> pr "%s\n" line
+ );
+ loop ()
+ in
+ (try loop () with End_of_file -> ());
+ )
+ in
dump "bindtests"
diff --git a/generator/utils.ml b/generator/utils.ml
index b818a0b3c..e91fed577 100644
--- a/generator/utils.ml
+++ b/generator/utils.ml
@@ -179,19 +179,13 @@ type memo_value = string list (* list of lines of POD file *)
let pod2text_memo_filename = "generator/.pod2text.data.version.2"
let pod2text_memo : (memo_key, memo_value) Hashtbl.t =
- try
- let chan = open_in pod2text_memo_filename in
- let v = input_value chan in
- close_in chan;
- v
- with
- _ -> Hashtbl.create 13
+ try with_open_in pod2text_memo_filename input_value
+ with _ -> Hashtbl.create 13
let pod2text_memo_unsaved_count = ref 0
let pod2text_memo_atexit = ref false
let pod2text_memo_save () =
- let chan = open_out pod2text_memo_filename in
- output_value chan pod2text_memo;
- close_out chan
+ with_open_out pod2text_memo_filename
+ (fun chan -> output_value chan pod2text_memo)
let pod2text_memo_updated () =
if not (!pod2text_memo_atexit) then (
at_exit pod2text_memo_save;
diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index 49290c298..f4c5c90d1 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -66,12 +66,7 @@ let rmdir t path =
with_fork t (sprintf "rmdir: %s" path) (fun () -> rmdir path)
let output t path f =
- with_fork t path (
- fun () ->
- let chan = open_out path in
- f chan;
- close_out chan
- )
+ with_fork t path (fun () -> with_open_out path f)
let make_file t path content =
output t path (fun chan -> output_string chan content)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index f1a67fc14..3e41016c5 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -226,9 +226,7 @@ read the man page virt-v2v-copy-to-local(1).
let guest_xml = guest_name ^ ".xml" in
message (f_"Writing libvirt XML metadata to %s ...") guest_xml;
- let chan = open_out guest_xml in
- output_string chan xml;
- close_out chan;
+ with_open_out guest_xml (fun chan -> output_string chan xml);
(* Finished, so don't delete the disks on exit. *)
message (f_"Finishing off");
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index 63e76a5aa..e29fbc2b7 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -240,10 +240,11 @@ object
"password=-"
| Some password ->
let password_file = tmpdir // "password" in
- let chan = open_out password_file in
- chmod password_file 0o600;
- output_string chan password;
- close_out chan;
+ with_open_out password_file (
+ fun chan ->
+ chmod password_file 0o600;
+ output_string chan password
+ );
(* nbdkit reads the password from the file *)
"password=+" ^ password_file in
add_arg (sprintf "server=%s" server);
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index abb0654a5..ff00118b3 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -215,29 +215,31 @@ object
debug "processing manifest %s" mf;
let mf_folder = Filename.dirname mf in
let mf_subfolder = subdirectory exploded mf_folder in
- let chan = open_in mf in
- let rec loop () =
- let line = input_line chan in
- if PCRE.matches rex line then (
- let mode = PCRE.sub 1
- and disk = PCRE.sub 2
- and expected = PCRE.sub 3 in
- let csum = Checksums.of_string mode expected in
- try
- if partial then
- Checksums.verify_checksum csum ~tar:ova (mf_subfolder // disk)
+ with_open_in mf (
+ fun chan ->
+ let rec loop () =
+ let line = input_line chan in
+ if PCRE.matches rex line then (
+ let mode = PCRE.sub 1
+ and disk = PCRE.sub 2
+ and expected = PCRE.sub 3 in
+ let csum = Checksums.of_string mode expected in
+ try
+ if partial then
+ Checksums.verify_checksum csum
+ ~tar:ova (mf_subfolder // disk)
+ else
+ Checksums.verify_checksum csum (mf_folder // disk)
+ with Checksums.Mismatched_checksum (_, actual) ->
+ error (f_"checksum of disk %s does not match manifest %s (actual %s(%s) = %s, expected %s(%s) = %s)")
+ disk mf mode disk actual mode disk expected;
+ )
else
- Checksums.verify_checksum csum (mf_folder // disk)
- with Checksums.Mismatched_checksum (_, actual) ->
- error (f_"checksum of disk %s does not match manifest %s (actual %s(%s) = %s, expected %s(%s) = %s)")
- disk mf mode disk actual mode disk expected;
- )
- else
- warning (f_"unable to parse line from manifest file: %S") line;
- loop ()
- in
- (try loop () with End_of_file -> ());
- close_in chan
+ warning (f_"unable to parse line from manifest file: %S") line;
+ loop ()
+ in
+ (try loop () with End_of_file -> ())
+ )
) mf;
let ovf_folder = Filename.dirname ovf in
diff --git a/v2v/output_local.ml b/v2v/output_local.ml
index 93d643f03..97ad8dddd 100644
--- a/v2v/output_local.ml
+++ b/v2v/output_local.ml
@@ -67,9 +67,7 @@ class output_local dir = object
let name = source.s_name in
let file = dir // name ^ ".xml" in
- let chan = open_out file in
- DOM.doc_to_chan chan doc;
- close_out chan
+ with_open_out file (fun chan -> DOM.doc_to_chan chan doc)
end
let output_local = new output_local
diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml
index 5304329ae..f61d698d6 100644
--- a/v2v/output_qemu.ml
+++ b/v2v/output_qemu.ml
@@ -229,23 +229,24 @@ object
arg "-serial" "stdio";
(* Write the output file. *)
- let chan = open_out file in
- let fpf fs = fprintf chan fs in
- fpf "#!/bin/sh -\n";
- fpf "\n";
+ with_open_out file (
+ fun chan ->
+ let fpf fs = fprintf chan fs in
+ fpf "#!/bin/sh -\n";
+ fpf "\n";
- (match uefi_firmware with
- | None -> ()
- | Some { Uefi.vars = vars_template } ->
- fpf "# Make a copy of the UEFI variables template\n";
- fpf "uefi_vars=\"$(mktemp)\"\n";
- fpf "cp %s \"$uefi_vars\"\n" (quote vars_template);
- fpf "\n"
+ (match uefi_firmware with
+ | None -> ()
+ | Some { Uefi.vars = vars_template } ->
+ fpf "# Make a copy of the UEFI variables template\n";
+ fpf "uefi_vars=\"$(mktemp)\"\n";
+ fpf "cp %s \"$uefi_vars\"\n" (quote vars_template);
+ fpf "\n"
+ );
+
+ Qemuopts.to_chan cmd chan
);
- Qemuopts.to_chan cmd chan;
- close_out chan;
-
Unix.chmod file 0o755;
(* If --qemu-boot option was specified then we should boot the guest. *)
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 0aeee289d..d5911e80e 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -144,9 +144,7 @@ object
List.iter (
fun ({ target_file }, meta) ->
let meta_filename = target_file ^ ".meta" in
- let chan = open_out meta_filename in
- output_string chan meta;
- close_out chan
+ with_open_out meta_filename (fun chan -> output_string chan meta)
) (List.combine targets metas);
(* Return the list of targets. *)
@@ -177,9 +175,7 @@ object
(* Write it to the metadata file. *)
let file = vdsm_params.ovf_output // vdsm_params.vm_uuid ^ ".ovf" in
- let chan = open_out file in
- DOM.doc_to_chan chan ovf;
- close_out chan
+ with_open_out file (fun chan -> DOM.doc_to_chan chan ovf)
end
let output_vdsm = new output_vdsm
--
2.13.2
More information about the Libguestfs
mailing list