[Libguestfs] [PATCH 1/3] generator: isolate memoized cache in own module
Pino Toscano
ptoscano at redhat.com
Tue Aug 13 13:04:25 UTC 2019
Isolate the logic for the memoized disk cache in a small module, so it
can be reused for other tools.
Other than refactoring, there should be no behaviour changes.
---
generator/Makefile.am | 3 ++
generator/memoized_cache.ml | 62 ++++++++++++++++++++++++
generator/memoized_cache.mli | 29 ++++++++++++
generator/utils.ml | 92 ++++++++++++++++--------------------
4 files changed, 134 insertions(+), 52 deletions(-)
create mode 100644 generator/memoized_cache.ml
create mode 100644 generator/memoized_cache.mli
diff --git a/generator/Makefile.am b/generator/Makefile.am
index 283cf3769..fd854ad03 100644
--- a/generator/Makefile.am
+++ b/generator/Makefile.am
@@ -85,6 +85,8 @@ sources = \
lua.mli \
main.ml \
main.mli \
+ memoized_cache.ml \
+ memoized_cache.mli \
OCaml.ml \
OCaml.mli \
optgroups.ml \
@@ -121,6 +123,7 @@ sources = \
# In build dependency order.
objects = \
types.cmo \
+ memoized_cache.cmo \
utils.cmo \
proc_nr.cmo \
actions_augeas.cmo \
diff --git a/generator/memoized_cache.ml b/generator/memoized_cache.ml
new file mode 100644
index 000000000..91493942e
--- /dev/null
+++ b/generator/memoized_cache.ml
@@ -0,0 +1,62 @@
+(* libguestfs
+ * Copyright (C) 2009-2019 Red Hat Inc.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+(* Please read generator/README first. *)
+
+open Std_utils
+
+open Printf
+
+type ('a, 'b) t = {
+ memo : ('a, 'b) Hashtbl.t;
+ filename : string;
+ lookup_fn : 'a -> 'b;
+ batch_size : int;
+ mutable unsaved_count : int;
+}
+
+let memo_save t =
+ with_open_out t.filename
+ (fun chan -> output_value chan t.memo);
+ t.unsaved_count <- 0
+
+let memo_updated t =
+ t.unsaved_count <- t.unsaved_count + 1;
+ if t.unsaved_count >= t.batch_size then
+ memo_save t
+
+let create ?(version = 1) ?(batch_size = 100) name lookup_fn =
+ let filename = sprintf "generator/.%s.data.version.%d" name version in
+ let memo =
+ try with_open_in filename input_value
+ with _ -> Hashtbl.create 13 in
+ {
+ memo; filename; lookup_fn; batch_size; unsaved_count = 0;
+ }
+
+let save t =
+ if t.unsaved_count > 0 then
+ memo_save t
+
+let find t key =
+ try Hashtbl.find t.memo key
+ with Not_found ->
+ let res = t.lookup_fn key in
+ Hashtbl.add t.memo key res;
+ memo_updated t;
+ res
diff --git a/generator/memoized_cache.mli b/generator/memoized_cache.mli
new file mode 100644
index 000000000..7ad6c7319
--- /dev/null
+++ b/generator/memoized_cache.mli
@@ -0,0 +1,29 @@
+(* libguestfs
+ * Copyright (C) 2009-2019 Red Hat Inc.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *)
+
+(* Please read generator/README first. *)
+
+(** A simple memoized cache. *)
+
+type ('a, 'b) t
+
+val create : ?version:int -> ?batch_size:int -> string -> ('a -> 'b) -> ('a, 'b) t
+
+val find : ('a, 'b) t -> 'a -> 'b
+
+val save : ('a, 'b) t -> unit
diff --git a/generator/utils.ml b/generator/utils.ml
index 460b61384..dea352afd 100644
--- a/generator/utils.ml
+++ b/generator/utils.ml
@@ -176,26 +176,44 @@ let html_escape text =
type memo_key = int option * bool * bool * string * string
(* width, trim, discard, name, longdesc *)
type memo_value = string list (* list of lines of POD file *)
+let run_pod2text (width, trim, discard, name, longdesc) =
+ let filename, chan = Filename.open_temp_file "gen" ".tmp" in
+ fprintf chan "=encoding utf8\n\n";
+ fprintf chan "=head1 %s\n\n%s\n" name longdesc;
+ close_out chan;
+ let cmd =
+ match width with
+ | Some width ->
+ sprintf "pod2text -w %d %s" width (Filename.quote filename)
+ | None ->
+ sprintf "pod2text %s" (Filename.quote filename) in
+ let chan = open_process_in cmd in
+ let lines = ref [] in
+ let rec loop i =
+ let line = input_line chan in
+ if i = 1 && discard then (* discard the first line of output *)
+ loop (i+1)
+ else (
+ let line = if trim then String.triml line else line in
+ lines := line :: !lines;
+ loop (i+1)
+ ) in
+ let lines : memo_value = try loop 1 with End_of_file -> List.rev !lines in
+ unlink filename;
+ (match close_process_in chan with
+ | WEXITED 0 -> ()
+ | WEXITED i ->
+ failwithf "pod2text: process exited with non-zero status (%d)" i
+ | WSIGNALED i | WSTOPPED i ->
+ failwithf "pod2text: process signalled or stopped by signal %d" i
+ );
+ lines
+let pod2text_memo : (memo_key, memo_value) Memoized_cache.t =
+ Memoized_cache.create ~version:2 "pod2text" run_pod2text
-let pod2text_memo_filename = "generator/.pod2text.data.version.2"
-let pod2text_memo : (memo_key, memo_value) Hashtbl.t =
- 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 () =
- 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;
- pod2text_memo_atexit := true;
- );
- pod2text_memo_unsaved_count := !pod2text_memo_unsaved_count + 1;
- if !pod2text_memo_unsaved_count >= 100 then (
- pod2text_memo_save ();
- pod2text_memo_unsaved_count := 0;
- )
+ Memoized_cache.save pod2text_memo
(* Useful if you need the longdesc POD text as plain text. Returns a
* list of lines.
@@ -205,41 +223,11 @@ let pod2text_memo_updated () =
*)
let pod2text ?width ?(trim = true) ?(discard = true) name longdesc =
let key : memo_key = width, trim, discard, name, longdesc in
- try Hashtbl.find pod2text_memo key
- with Not_found ->
- let filename, chan = Filename.open_temp_file "gen" ".tmp" in
- fprintf chan "=encoding utf8\n\n";
- fprintf chan "=head1 %s\n\n%s\n" name longdesc;
- close_out chan;
- let cmd =
- match width with
- | Some width ->
- sprintf "pod2text -w %d %s" width (Filename.quote filename)
- | None ->
- sprintf "pod2text %s" (Filename.quote filename) in
- let chan = open_process_in cmd in
- let lines = ref [] in
- let rec loop i =
- let line = input_line chan in
- if i = 1 && discard then (* discard the first line of output *)
- loop (i+1)
- else (
- let line = if trim then String.triml line else line in
- lines := line :: !lines;
- loop (i+1)
- ) in
- let lines : memo_value = try loop 1 with End_of_file -> List.rev !lines in
- unlink filename;
- (match close_process_in chan with
- | WEXITED 0 -> ()
- | WEXITED i ->
- failwithf "pod2text: process exited with non-zero status (%d)" i
- | WSIGNALED i | WSTOPPED i ->
- failwithf "pod2text: process signalled or stopped by signal %d" i
- );
- Hashtbl.add pod2text_memo key lines;
- pod2text_memo_updated ();
- lines
+ if not (!pod2text_memo_atexit) then (
+ at_exit pod2text_memo_save;
+ pod2text_memo_atexit := true;
+ );
+ Memoized_cache.find pod2text_memo key
(* Compare two actions (for sorting). *)
let action_compare { name = n1 } { name = n2 } = compare n1 n2
--
2.21.0
More information about the Libguestfs
mailing list