Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 0/9] build: Require OCaml >= 4.02.
Per my previous email: https://www.redhat.com/archives/libguestfs/2017-September/msg00203.html I'd like to talk about requiring a more modern version of the OCaml compiler. These commits show some of the code changes which would be possible with OCaml >= 3.12 [which it turns out we already require by accident] and also with OCaml >= 4.02. The latter is my favoured option. Rich.
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 1/9] build: Require OCaml >= 4.02.
RHEL 6, RHEL <= 7.4, Debian 8 and Ubuntu 14.04 are no longer supported
(unless OCaml and other components are upgraded).
See: https://www.redhat.com/archives/libguestfs/2017-September/msg00203.html
---
docs/guestfs-building.pod | 2 +-
m4/guestfs_ocaml.m4 | 12 ++++++------
2 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/docs/guestfs-building.pod b/docs/guestfs-building.pod
index 187da37be..d7a0b521b 100644
--- a/docs/guestfs-building.pod
+++ b/docs/guestfs-building.pod
@@ -116,7 +116,7 @@ virt tools which are still written in Perl.
I<Required>. Part of Perl core.
-=item OCaml E<ge> 3.11
+=item OCaml E<ge> 4.02
=item OCaml findlib
diff --git a/m4/guestfs_ocaml.m4 b/m4/guestfs_ocaml.m4
index f3d470929..162ec0dde 100644
--- a/m4/guestfs_ocaml.m4
+++ b/m4/guestfs_ocaml.m4
@@ -38,15 +38,15 @@ AC_ARG_ENABLE([ocaml],
[],
[enable_ocaml=yes])
-dnl OCaml >= 3.11 is required.
-AC_MSG_CHECKING([if OCaml version >= 3.11])
+dnl OCaml >= 4.02 is required.
+AC_MSG_CHECKING([if OCaml version >= 4.02])
ocaml_major="`echo $OCAMLVERSION | $AWK -F. '{print $1}'`"
-ocaml_minor="`echo $OCAMLVERSION | $AWK -F. '{print $2}'`"
-AS_IF([test "$ocaml_major" -ge 4 || ( test "$ocaml_major"
-eq 3 && test "$ocaml_minor" -ge 11 )],[
- AC_MSG_RESULT([yes])
+ocaml_minor="`echo $OCAMLVERSION | $AWK -F. '{print $2}' | sed
's/^0//'`"
+AS_IF([test "$ocaml_major" -ge 5 || ( test "$ocaml_major"
-eq 4 && test "$ocaml_minor" -ge 2 )],[
+ AC_MSG_RESULT([yes ($ocaml_major, $ocaml_minor)])
],[
AC_MSG_RESULT([no])
- AC_MSG_FAILURE([OCaml compiler is not new enough. At least OCaml 3.11 is
required])
+ AC_MSG_FAILURE([OCaml compiler is not new enough. At least OCaml 4.02 is
required])
])
AM_CONDITIONAL([HAVE_OCAML],
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 2/9] ocaml: Replace pattern matching { field = field } with { field }.
If you have a struct containing ?field?, eg:
type t = { field : int }
then previously to pattern-match on this type, eg. in function
parameters, you had to write:
let f { field = field } (* ... use field ... *)
In OCaml >= 3.12 it is possible to abbreviate cases where the field
being matched and the variable being bound have the same name, so now
you can just write:
let f { field } (* ... use field ... *)
(Similarly for a field prefixed by a Module name you can use
?{ Module.field }? instead of ?{ Module.field = field }?).
This style is widely used inside the OCaml compiler sources, and is
briefer than the long form, so it makes sense to use it. Furthermore
there was one place in virt-dib where we are already using this new
style, so the old code did not compile on OCaml < 3.12.
See also:
https://forge.ocamlcore.org/docman/view.php/77/112/leroy-cug2010.pdf
---
builder/builder.ml | 22 ++++++++++------------
builder/index.ml | 19 ++++---------------
builder/index_parser.ml | 3 +--
builder/list_entries.ml | 27 +++++++--------------------
builder/simplestreams_parser.ml | 3 +--
common/mltools/curl.ml | 4 ++--
common/mlvisit/visit_tests.ml | 4 ++--
customize/append_line.ml | 4 ++--
customize/customize_main.ml | 4 +---
daemon/inspect.ml | 2 +-
daemon/inspect_fs.ml | 7 +++----
daemon/inspect_types.ml | 9 ++++-----
dib/output_format.ml | 2 +-
generator/GObject.ml | 15 +++++++--------
generator/OCaml.ml | 13 ++++++-------
generator/bindtests.ml | 5 ++---
generator/c.ml | 26 +++++++++++++-------------
generator/checks.ml | 32 ++++++++++++++++----------------
generator/csharp.ml | 4 ++--
generator/daemon.ml | 16 ++++++++--------
generator/erlang.ml | 12 ++++++------
generator/fish.ml | 28 +++++++++++++---------------
generator/golang.ml | 3 +--
generator/haskell.ml | 4 ++--
generator/java.ml | 2 +-
generator/lua.ml | 6 +++---
generator/main.ml | 4 ++--
generator/perl.ml | 7 +++----
generator/php.ml | 6 +++---
generator/python.ml | 10 ++++------
generator/ruby.ml | 3 +--
generator/tests_c_api.ml | 6 +++---
get-kernel/get_kernel.ml | 4 +---
ocaml/t/guestfs_100_launch.ml | 2 +-
resize/resize.ml | 12 +++++-------
sparsify/utils.ml | 2 +-
sysprep/main.ml | 4 +---
sysprep/sysprep_operation.ml | 8 ++++----
v2v/changeuid.ml | 2 +-
v2v/input_ova.ml | 2 +-
v2v/output_glance.ml | 2 +-
v2v/output_qemu.ml | 4 ++--
v2v/output_rhv.ml | 2 +-
v2v/output_vdsm.ml | 2 +-
v2v/utils.ml | 2 +-
v2v/v2v.ml | 2 +-
46 files changed, 157 insertions(+), 205 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index d8e625f68..bf3f52f6a 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -49,7 +49,7 @@ let remove_duplicates index *)
let nseen = Hashtbl.create 13 in
List.iter (
- fun (name, { Index.arch = arch; revision = revision }) ->
+ fun (name, { Index.arch; revision }) ->
let id = name, arch in
try
let rev = Hashtbl.find nseen id in
@@ -59,7 +59,7 @@ let remove_duplicates index Hashtbl.add nseen id
revision
) index;
List.filter (
- fun (name, { Index.arch = arch; revision = revision }) ->
+ fun (name, { Index.arch ; revision }) ->
let id = name, arch in
try
let rev = Hashtbl.find nseen (name, arch) in
@@ -84,7 +84,7 @@ let selected_cli_item cmdline index try
let item List.find (
- fun (name, { Index.aliases = aliases }) ->
+ fun (name, { Index.aliases }) ->
match aliases with
| None -> false
| Some l -> List.mem cmdline.arg l
@@ -232,11 +232,11 @@ let main () (match cache with
| Some cache ->
let l = List.filter (
- fun (_, { Index.hidden = hidden }) ->
+ fun (_, { Index.hidden }) ->
hidden <> true
) index in
let l = List.map (
- fun (name, { Index.revision = revision; arch = arch }) ->
+ fun (name, { Index.revision; arch }) ->
(name, arch, revision)
) l in
Cache.print_item_status cache ~header:true l
@@ -251,8 +251,7 @@ let main () | Some _ ->
List.iter (
fun (name,
- { Index.revision = revision; file_uri = file_uri;
- proxy = proxy }) ->
+ { Index.revision; file_uri; proxy }) ->
let template = name, cmdline.arch, revision in
message (f_"Downloading: %s") file_uri;
let progress_bar = not (quiet ()) in
@@ -300,8 +299,7 @@ let main () (* Download the template, or it may be in the
cache. *)
let template let template, delete_on_exit - let { Index.revision =
revision; file_uri = file_uri;
- proxy = proxy } = entry in
+ let { Index.revision; file_uri; proxy } = entry in
let template = arg, cmdline.arch, revision in
message (f_"Downloading: %s") file_uri;
let progress_bar = not (quiet ()) in
@@ -340,7 +338,7 @@ let main ()
(* Planner: Input tags. *)
let itags - let { Index.size = size; format = format } = entry in
+ let { Index.size; format } = entry in
let format_tag match format with
| None -> []
@@ -590,7 +588,7 @@ let main () let osize = Int64.of_string (List.assoc
`Size otags) in
let osize = roundup64 osize 512L in
let oformat = List.assoc `Format otags in
- let { Index.expand = expand; lvexpand = lvexpand } = entry in
+ let { Index.expand; lvexpand } = entry in
message (f_"Resizing (using virt-resize) to expand the disk to
%s")
(human_size osize);
let preallocation = if oformat = "qcow2" then Some
"metadata" else None in
@@ -691,7 +689,7 @@ let main () let filesystems = List.map snd
(g#mountpoints ()) in
let stats = List.map g#statvfs filesystems in
let stats = List.map (
- fun { G.bfree = bfree; bsize = bsize; blocks = blocks } ->
+ fun { G.bfree; bsize; blocks } ->
bfree *^ bsize, blocks *^ bsize
) stats in
List.fold_left (
diff --git a/builder/index.ml b/builder/index.ml
index b5f51163f..b895e3f52 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -47,21 +47,10 @@ and entry = {
proxy : Curl.proxy;
}
-let print_entry chan (name, { printable_name = printable_name;
- file_uri = file_uri;
- arch = arch;
- osinfo = osinfo;
- signature_uri = signature_uri;
- checksums = checksums;
- revision = revision;
- format = format;
- size = size;
- compressed_size = compressed_size;
- expand = expand;
- lvexpand = lvexpand;
- notes = notes;
- aliases = aliases;
- hidden = hidden }) +let print_entry chan (name, {
printable_name; file_uri; arch; osinfo;
+ signature_uri; checksums; revision; format;
+ size; compressed_size; expand; lvexpand;
+ notes; aliases; hidden }) let fp fs = fprintf
chan fs in
fp "[%s]\n" name;
may (fp "name=%s\n") printable_name;
diff --git a/builder/index_parser.ml b/builder/index_parser.ml
index 66e921ec4..d6a4e2e86 100644
--- a/builder/index_parser.ml
+++ b/builder/index_parser.ml
@@ -25,8 +25,7 @@ open Utils
open Printf
open Unix
-let get_index ~downloader ~sigchecker
- { Sources.uri = uri; proxy = proxy } +let get_index ~downloader ~sigchecker {
Sources.uri; proxy } let corrupt_file () error (f_"The index file
downloaded from ?%s? is corrupt.\nYou need to ask the supplier of this file to
fix it and upload a fixed version.") uri
in
diff --git a/builder/list_entries.ml b/builder/list_entries.ml
index c0aae1675..2cd030fca 100644
--- a/builder/list_entries.ml
+++ b/builder/list_entries.ml
@@ -43,9 +43,7 @@ let rec list_entries ~list_format ~sources index
and list_entries_short index List.iter (
- fun (name, { Index.printable_name = printable_name;
- arch = arch;
- hidden = hidden }) ->
+ fun (name, { Index.printable_name; arch; hidden }) ->
if not hidden then (
printf "%-24s" name;
printf " %-10s" arch;
@@ -58,7 +56,7 @@ and list_entries_long ~sources index let langs =
Languages.languages () in
List.iter (
- fun { Sources.uri = uri; gpgkey = gpgkey } ->
+ fun { Sources.uri; gpgkey } ->
printf (f_"Source URI: %s\n") uri;
(match gpgkey with
| Utils.No_Key -> ()
@@ -71,13 +69,8 @@ and list_entries_long ~sources index ) sources;
List.iter (
- fun (name, { Index.printable_name = printable_name;
- arch = arch;
- size = size;
- compressed_size = compressed_size;
- notes = notes;
- aliases = aliases;
- hidden = hidden }) ->
+ fun (name, { Index.printable_name; arch; size; compressed_size;
+ notes; aliases; hidden }) ->
if not hidden then (
printf "%-24s %s\n" "os-version:" name;
may (printf "%-24s %s\n" (s_"Full name:"))
printable_name;
@@ -107,7 +100,7 @@ and list_entries_long ~sources index and list_entries_json
~sources index let json_sources List.map (
- fun { Sources.uri = uri; gpgkey = gpgkey } ->
+ fun { Sources.uri; gpgkey } ->
let item = [ "uri", JSON.String uri ] in
let item match gpgkey with
@@ -120,14 +113,8 @@ and list_entries_json ~sources index ) sources in
let json_templates List.map (
- fun (name, { Index.printable_name = printable_name;
- arch = arch;
- size = size;
- compressed_size = compressed_size;
- notes = notes;
- aliases = aliases;
- osinfo = osinfo;
- hidden = hidden }) ->
+ fun (name, { Index.printable_name; arch; size; compressed_size;
+ notes; aliases; osinfo; hidden }) ->
let item = [ "os-version", JSON.String name ] in
let item match printable_name with
diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml
index 7f1a4e726..75592e377 100644
--- a/builder/simplestreams_parser.ml
+++ b/builder/simplestreams_parser.ml
@@ -29,8 +29,7 @@ let ensure_trailing_slash str if String.length str > 0
&& str.[String.length str - 1] <> '/' then str ^
"/"
else str
-let get_index ~downloader ~sigchecker
- { Sources.uri = uri; proxy = proxy } +let get_index ~downloader ~sigchecker {
Sources.uri; proxy }
let uri = ensure_trailing_slash uri in
diff --git a/common/mltools/curl.ml b/common/mltools/curl.ml
index 85fe1a8b2..e2bd0c283 100644
--- a/common/mltools/curl.ml
+++ b/common/mltools/curl.ml
@@ -44,7 +44,7 @@ let create ?(curl = "curl") ?(proxy = SystemProxy)
?tmpdir args let args = safe_args @ args_of_proxy proxy @ args in
{ curl = curl; args = args; tmpdir = tmpdir }
-let run { curl = curl; args = args; tmpdir = tmpdir } +let run { curl; args;
tmpdir } let config_file, chan = Filename.open_temp_file ?temp_dir:tmpdir
"guestfscurl" ".conf" in
List.iter (
@@ -75,7 +75,7 @@ let run { curl = curl; args = args; tmpdir = tmpdir }
Unix.unlink config_file;
lines
-let to_string { curl = curl; args = args } +let to_string { curl; args } let
b = Buffer.create 128 in
bprintf b "%s -q" (quote curl);
List.iter (
diff --git a/common/mlvisit/visit_tests.ml b/common/mlvisit/visit_tests.ml
index 7b0f01347..6753dfb90 100644
--- a/common/mlvisit/visit_tests.ml
+++ b/common/mlvisit/visit_tests.ml
@@ -145,7 +145,7 @@ and string_of_stat { G.st_mode = mode } and
string_of_xattrs xattrs String.concat "" (List.map string_of_xattr
(Array.to_list xattrs))
-and string_of_xattr { G.attrname = name; G.attrval = v } - sprintf "
%s=%s" name v
+and string_of_xattr { G.attrname; attrval } + sprintf " %s=%s"
attrname attrval
let () = main ()
diff --git a/customize/append_line.ml b/customize/append_line.ml
index 3371c73ac..d37c3ef3b 100644
--- a/customize/append_line.ml
+++ b/customize/append_line.ml
@@ -39,8 +39,8 @@ let append_line (g : G.guestfs) root path line (* Stat
the file. We want to know it's a regular file, and
* also its size.
*)
- let { G.st_mode = mode; st_size = size } = g#statns path in
- if Int64.logand mode 0o170000_L <> 0o100000_L then
+ let { G.st_mode; st_size = size } = g#statns path in
+ if Int64.logand st_mode 0o170000_L <> 0o100000_L then
error (f_"append_line: %s is not a file") path;
(* Guess the line ending from the first part of the file, else
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index 55e1b6d8e..aad6ebe65 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -134,9 +134,7 @@ read the man page virt-customize(1).
fun g readonly ->
List.iter (
fun (uri, format) ->
- let { URI.path = path; protocol = protocol;
- server = server; username = username;
- password = password } = uri in
+ let { URI.path; protocol; server; username; password } = uri in
let discard = if readonly then None else Some
"besteffort" in
g#add_drive
~readonly ?discard
diff --git a/daemon/inspect.ml b/daemon/inspect.ml
index 0f5bcfc10..ecc45e7c7 100644
--- a/daemon/inspect.ml
+++ b/daemon/inspect.ml
@@ -145,7 +145,7 @@ and check_for_duplicated_bsd_root fses let bsd_primary
List.find (
function
- | { fs_location = { mountable = mountable };
+ | { fs_location = { mountable };
role = RoleRoot { os_type = Some t } } ->
(t = OS_TYPE_FREEBSD || t = OS_TYPE_NETBSD || t = OS_TYPE_OPENBSD)
&& is_primary_partition mountable
diff --git a/daemon/inspect_fs.ml b/daemon/inspect_fs.ml
index 10a15827b..1d3aadcc0 100644
--- a/daemon/inspect_fs.ml
+++ b/daemon/inspect_fs.ml
@@ -65,8 +65,7 @@ let rec check_for_filesystem_on mountable vfs_type match
role with
| None -> None
| Some role ->
- Some { fs_location = { mountable = mountable; vfs_type = vfs_type };
- role = role }
+ Some { fs_location = { mountable ; vfs_type }; role }
(* When this function is called, the filesystem is mounted on sysroot (). *)
and check_filesystem mountable @@ -245,7 +244,7 @@ and is_symlink_to file
wanted_target * simple function of the [distro] and [version[0]] fields, so
these
* can never return an error. We might be cleverer in future.
*)
-and check_package_format { distro = distro } +and check_package_format { distro
} match distro with
| None -> None
| Some DISTRO_FEDORA
@@ -290,7 +289,7 @@ and check_package_format { distro = distro } | Some
DISTRO_PLD_LINUX ->
None
-and check_package_management { distro = distro; version = version } +and
check_package_management { distro; version } let major = match version with
None -> 0 | Some (major, _) -> major in
match distro with
| None -> None
diff --git a/daemon/inspect_types.ml b/daemon/inspect_types.ml
index 4570349ba..a687ea08c 100644
--- a/daemon/inspect_types.ml
+++ b/daemon/inspect_types.ml
@@ -123,7 +123,7 @@ and version = int * int
and fstab_entry = Mountable.t * string (* mountable, mountpoint *)
and drive_mapping = string * string (* drive name, device *)
-let rec string_of_fs { fs_location = location; role = role } +let rec
string_of_fs { fs_location = location; role } sprintf "fs: %s role:
%s\n"
(string_of_location location)
(match role with
@@ -132,13 +132,12 @@ let rec string_of_fs { fs_location = location; role = role
} | RoleSwap -> "swap"
| RoleOther -> "other")
-and string_of_location { mountable = mountable; vfs_type = vfs_type } +and
string_of_location { mountable ; vfs_type } sprintf "%s (%s)"
(Mountable.to_string mountable) vfs_type
-and string_of_root { root_location = location;
- inspection_data = inspection_data } +and string_of_root {
root_location; inspection_data } sprintf "%s:\n%s"
- (string_of_location location)
+ (string_of_location root_location)
(string_of_inspection_data inspection_data)
and string_of_inspection_data data diff --git a/dib/output_format.ml
b/dib/output_format.ml
index 537469ab6..79a90ae35 100644
--- a/dib/output_format.ml
+++ b/dib/output_format.ml
@@ -106,7 +106,7 @@ let extra_args () assert !baked;
List.flatten (
- List.map (fun { extra_args = extra_args } ->
+ List.map (fun { extra_args } ->
List.map (fun { extra_argspec = argspec } -> argspec) extra_args
) !all_formats
)
diff --git a/generator/GObject.ml b/generator/GObject.ml
index 94499fa13..9d4d6b2fa 100644
--- a/generator/GObject.ml
+++ b/generator/GObject.ml
@@ -33,7 +33,7 @@ open Utils
let generate_header = generate_header
~inputs:["generator/gobject.ml"]
-let camel_of_name { camel_name = camel_name } = "Guestfs" ^
camel_name
+let camel_of_name { camel_name } = "Guestfs" ^ camel_name
let generate_gobject_proto name ?(single_line = true)
(ret, args, optargs) f @@ -106,7 +106,7 @@ let
filenames List.map (fun { s_name = typ } -> "struct-" ^ typ)
external_structs @
(* optargs *)
- List.map (function { name = name } -> "optargs-" ^ name) (
+ List.map (function { name } -> "optargs-" ^ name) (
List.filter (
function
| { style = _, _, (_::_) } -> true
@@ -680,7 +680,7 @@ gboolean guestfs_session_close (GuestfsSession *session,
GError **err);
";
List.iter (
- fun ({ name = name; style = style } as f) ->
+ fun ({ name; style } as f) ->
generate_gobject_proto name style f;
pr ";\n";
) (actions |> external_functions |> sort);
@@ -936,11 +936,10 @@ guestfs_session_close (GuestfsSession *session, GError
**err)
let literal = Str.regexp "\\(^\\|\n\\)[
\t]+\\([^\n]*\\)\\(\n\\|$\\)" in
List.iter (
- fun ({ name = name; style = (ret, args, optargs as style);
- cancellable = cancellable; c_function = c_function;
- c_optarg_prefix = c_optarg_prefix;
- shortdesc = shortdesc; longdesc = longdesc;
- deprecated_by = deprecated_by } as f) ->
+ fun ({ name; style = (ret, args, optargs as style);
+ cancellable; c_function; c_optarg_prefix;
+ shortdesc; longdesc;
+ deprecated_by } as f) ->
pr "\n";
let longdesc = Str.global_substitute urls (
diff --git a/generator/OCaml.ml b/generator/OCaml.ml
index 853b41bb3..9f880b55d 100644
--- a/generator/OCaml.ml
+++ b/generator/OCaml.ml
@@ -218,7 +218,7 @@ end
(* The actions. *)
List.iter (
- fun ({ name = name; style = style; non_c_aliases = non_c_aliases } as f)
->
+ fun ({ name; style; non_c_aliases } as f) ->
generate_doc f (fun () -> generate_ocaml_prototype name style);
(* Aliases. *)
@@ -269,7 +269,7 @@ class guestfs : ?environment:bool -> ?close_on_exit:bool
-> unit -> object
";
List.iter (
- fun ({ name = name; style = style; non_c_aliases = non_c_aliases } as f)
->
+ fun ({ name; style; non_c_aliases } as f) ->
let indent = " " in
(match style with
@@ -369,7 +369,7 @@ let ()
(* The actions. *)
List.iter (
- fun { name = name; style = style; non_c_aliases = non_c_aliases } ->
+ fun { name; style; non_c_aliases } ->
generate_ocaml_prototype ~is_external:true name style;
List.iter (fun alias -> pr "let %s = %s\n" alias name)
non_c_aliases
) (actions |> external_functions |> sort);
@@ -387,7 +387,7 @@ class guestfs ?environment ?close_on_exit () ";
List.iter (
- fun { name = name; style = style; non_c_aliases = non_c_aliases } ->
+ fun { name; style; non_c_aliases } ->
(match style with
| _, [], optargs ->
(* No required params? Add explicit unit. *)
@@ -541,9 +541,8 @@ copy_table (char * const * argv)
(* The wrappers. *)
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- blocking = blocking;
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ blocking; c_function; c_optarg_prefix } ->
pr "/* Automatically generated wrapper for function\n";
pr " * ";
generate_ocaml_prototype name style;
diff --git a/generator/bindtests.ml b/generator/bindtests.ml
index d225146c0..4bdff8092 100644
--- a/generator/bindtests.ml
+++ b/generator/bindtests.ml
@@ -139,8 +139,7 @@ fill_lvm_pv (guestfs_h *g, struct guestfs_lvm_pv *pv, size_t
i)
| _ -> assert false in
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style); c_optarg_prefix } ->
pr "/* The %s function prints its parameters to stdout or
the\n" name;
pr " * file set by internal_test_set_output.\n";
pr " */\n";
@@ -213,7 +212,7 @@ fill_lvm_pv (guestfs_h *g, struct guestfs_lvm_pv *pv, size_t
i)
) ptests;
List.iter (
- fun { name = name; style = (ret, args, _ as style) } ->
+ fun { name; style = (ret, args, _ as style) } ->
if String.sub name (String.length name - 3) 3 <> "err"
then (
pr "/* Test normal return. */\n";
generate_prototype ~extern:false ~semicolon:false ~newline:true
diff --git a/generator/c.ml b/generator/c.ml
index 6396b4159..02d33ffc3 100644
--- a/generator/c.ml
+++ b/generator/c.ml
@@ -206,7 +206,7 @@ and generate_actions_pod ()
generate_actions_pod_entry f
) (actions |> documented_functions |> sort)
-and generate_actions_pod_entry ({ c_name = c_name;
+and generate_actions_pod_entry ({ c_name;
style = ret, args, optargs as style } as f)
pr "=head2 guestfs_%s\n\n" c_name;
generate_prototype ~extern:false ~indent:" " ~handle:"g"
@@ -319,7 +319,7 @@ L</guestfs_feature_available>.\n\n" opt
pr "See L</CALLS WITH OPTIONAL ARGUMENTS>.\n\n";
)
-and generate_actions_pod_back_compat_entry ({ name = name;
+and generate_actions_pod_back_compat_entry ({ name;
style = ret, args, _ } as f)
pr "=head2 guestfs_%s\n\n" name;
generate_prototype ~extern:false ~indent:" " ~handle:"g"
@@ -644,7 +644,7 @@ extern GUESTFS_DLL_PUBLIC void *guestfs_next_private
(guestfs_h *g, const char *
let generate_action_header { name = shortname;
style = ret, args, optargs as style;
- deprecated_by = deprecated_by } +
deprecated_by } pr "#define GUESTFS_HAVE_%s 1\n"
(String.uppercase_ascii shortname);
if optargs <> [] then (
@@ -705,7 +705,7 @@ extern GUESTFS_DLL_PUBLIC void *guestfs_next_private
(guestfs_h *g, const char *
in
let generate_all_headers = List.iter (
- fun ({ name = name; style = ret, args, _ } as f) ->
+ fun ({ name; style = ret, args, _ } as f) ->
(* If once_had_no_optargs is set, then we need to generate a
* <name>_opts variant, plus a backwards-compatible wrapper
* called just <name> with no optargs.
@@ -785,7 +785,7 @@ and generate_internal_actions_h () pr "\n";
List.iter (
- fun { c_name = c_name; style = style } ->
+ fun { c_name; style } ->
generate_prototype ~single_line:true ~newline:true ~handle:"g"
~prefix:"guestfs_impl_" ~optarg_proto:Argv
c_name style
@@ -1676,9 +1676,9 @@ and generate_client_actions actions () in
(* For non-daemon functions, generate a wrapper around each function. *)
- let generate_non_daemon_wrapper { name = name; c_name = c_name;
+ let generate_non_daemon_wrapper { name; c_name;
style = ret, _, optargs as style;
- config_only = config_only } +
config_only } if optargs = [] then
generate_prototype ~extern:false ~semicolon:false ~newline:true
~handle:"g" ~prefix:"guestfs_"
@@ -1756,7 +1756,7 @@ and generate_client_actions actions () ) (actions |>
non_daemon_functions |> sort);
(* Client-side stubs for each function. *)
- let generate_daemon_stub { name = name; c_name = c_name;
+ let generate_daemon_stub { name; c_name;
style = ret, args, optargs as style } let
errcode match errcode_of_ret ret with
@@ -2072,7 +2072,7 @@ and generate_client_actions_variants ()
";
- let generate_va_variants { name = name; c_name = c_name;
+ let generate_va_variants { name; c_name;
style = ret, args, optargs as style } assert
(optargs <> []); (* checked by caller *)
@@ -2175,7 +2175,7 @@ and generate_client_actions_variants () pr
";\n";
pr "}\n\n"
- and generate_back_compat_wrapper { name = name;
+ and generate_back_compat_wrapper { name;
style = ret, args, _ as style }
generate_prototype ~extern:false ~semicolon:false ~newline:true
~handle:"g" ~prefix:"guestfs_"
@@ -2305,13 +2305,13 @@ and generate_linker_script () List.flatten (
List.map (
function
- | { c_name = c_name; style = _, _, [] } -> ["guestfs_" ^
c_name]
- | { c_name = c_name; style = _, _, (_::_);
+ | { c_name; style = _, _, [] } -> ["guestfs_" ^ c_name]
+ | { c_name; style = _, _, (_::_);
once_had_no_optargs = false } ->
["guestfs_" ^ c_name;
"guestfs_" ^ c_name ^ "_va";
"guestfs_" ^ c_name ^ "_argv"]
- | { name = name; c_name = c_name; style = _, _, (_::_);
+ | { name; c_name; style = _, _, (_::_);
once_had_no_optargs = true } ->
["guestfs_" ^ name;
"guestfs_" ^ c_name;
diff --git a/generator/checks.ml b/generator/checks.ml
index be7b272a3..49a5a756d 100644
--- a/generator/checks.ml
+++ b/generator/checks.ml
@@ -41,7 +41,7 @@ let ()
(* Check function names. *)
List.iter (
- fun { name = name } ->
+ fun { name } ->
let len = String.length name in
if len >= 7 && String.sub name 0 7 = "guestfs" then
@@ -65,7 +65,7 @@ let () (* Check added field was set to something. *)
List.iter (
function
- | { name = name; visibility = VPublic|VPublicNoFish|VDebug;
+ | { name; visibility = VPublic|VPublicNoFish|VDebug;
added = (-1, _, _) } ->
failwithf "function %s has no 'added' (version when added)
field" name
| _ -> ()
@@ -73,7 +73,7 @@ let ()
(* Check function parameter/return names. *)
List.iter (
- fun { name = name; style = style } ->
+ fun { name; style } ->
let check_arg_ret_name n if contains_uppercase n then
failwithf "%s param/ret %s should not contain uppercase
chars"
@@ -137,14 +137,14 @@ let ()
(* Maximum of 63 optargs permitted. *)
List.iter (
- fun { name = name; style = _, _, optargs } ->
+ fun { name; style = _, _, optargs } ->
if List.length optargs > 63 then
failwithf "maximum of 63 optional args allowed for %s" name;
) actions;
(* Some parameter types not supported for daemon functions. *)
List.iter (
- fun { name = name; style = _, args, _ } ->
+ fun { name; style = _, args, _ } ->
let check_arg_type = function
| Pointer _ ->
failwithf "Pointer is not supported for daemon function
%s."
@@ -158,7 +158,7 @@ let () * not permitted.
*)
List.iter (
- fun { name = name; style = _, args, _ } ->
+ fun { name; style = _, args, _ } ->
let check_arg_type = function
(* Previously only DeviceList and FilenameList were special list
* types. We could permit more here in future.
@@ -179,7 +179,7 @@ let ()
(* Check short descriptions. *)
List.iter (
- fun { name = name; shortdesc = shortdesc } ->
+ fun { name; shortdesc } ->
if shortdesc.[0] <> Char.lowercase_ascii shortdesc.[0] then
failwithf "short description of %s should begin with
lowercase." name;
let c = shortdesc.[String.length shortdesc-1] in
@@ -189,7 +189,7 @@ let ()
(* Check long descriptions. *)
List.iter (
- fun { name = name; longdesc = longdesc } ->
+ fun { name; longdesc } ->
if longdesc.[String.length longdesc-1] = '\n' then
failwithf "long description of %s should not end with \\n."
name;
if longdesc.[0] <> Char.uppercase_ascii longdesc.[0] then
@@ -198,7 +198,7 @@ let ()
(* Check flags. *)
List.iter (
- fun ({ name = name; style = ret, _, _ } as f) ->
+ fun ({ name; style = ret, _, _ } as f) ->
List.iter (
fun n ->
if contains_uppercase n then
@@ -237,7 +237,7 @@ let () (* Check blocking flag is set on all daemon
functions. *)
List.iter (
function
- | { name = name; blocking = false } ->
+ | { name; blocking = false } ->
failwithf "%s: blocking flag should be 'true' on this daemon
function"
name
| { blocking = true } -> ()
@@ -246,7 +246,7 @@ let () (* Check wrapper flag is set on all daemon
functions. *)
List.iter (
function
- | { name = name; wrapper = false } ->
+ | { name; wrapper = false } ->
failwithf "%s: wrapper flag should be 'true' on this daemon
function"
name
| { wrapper = true } -> ()
@@ -254,7 +254,7 @@ let ()
(* Non-fish functions must have correct camel_name. *)
List.iter (
- fun { name = name; camel_name = camel_name } ->
+ fun { name; camel_name } ->
if not (contains_uppercase camel_name) then
failwithf "%s: camel case name must contain uppercase
characters"
name;
@@ -265,7 +265,7 @@ let () (* ConfigOnly should only be specified on
non_daemon_functions. *)
List.iter (
function
- | { name = name; config_only = true } ->
+ | { name; config_only = true } ->
failwithf "%s cannot have ConfigOnly flag" name
| { config_only = false } -> ()
) ((actions |> daemon_functions) @ fish_commands);
@@ -273,7 +273,7 @@ let () (* once_had_no_optargs can only apply if the
function now has optargs. *)
List.iter (
function
- | { name = name; once_had_no_optargs = true; style = _, _, [] } ->
+ | { name; once_had_no_optargs = true; style = _, _, [] } ->
failwithf "%s cannot have once_had_no_optargs flag and no
optargs" name
| { once_had_no_optargs = false } | { style = _, _, (_::_) } -> ()
) actions;
@@ -285,7 +285,7 @@ let () * warning when the user does 'make
check' instead.
*)
| { tests = [] } -> ()
- | { name = name; tests = tests } ->
+ | { name; tests } ->
let funcs List.map (
fun (_, _, test, _) ->
@@ -306,7 +306,7 @@ let () function
| { tests = [] }
| { optional = None } -> ()
- | { name = name; tests = tests; optional = Some optgroup } ->
+ | { name; tests; optional = Some optgroup } ->
List.iter (
function
| _, IfAvailable o, _, _ when o = optgroup ->
diff --git a/generator/csharp.ml b/generator/csharp.ml
index 0eab21f0d..773ab1291 100644
--- a/generator/csharp.ml
+++ b/generator/csharp.ml
@@ -138,8 +138,8 @@ namespace Guestfs
(* Generate C# function bindings. *)
List.iter (
- fun { name = name; style = ret, args, optargs; c_function = c_function;
- shortdesc = shortdesc; non_c_aliases = non_c_aliases } ->
+ fun { name; style = ret, args, optargs; c_function;
+ shortdesc; non_c_aliases } ->
let rec csharp_return_type () match ret with
| RErr -> "void"
diff --git a/generator/daemon.ml b/generator/daemon.ml
index 089ef509c..b8ee4081f 100644
--- a/generator/daemon.ml
+++ b/generator/daemon.ml
@@ -59,7 +59,7 @@ let generate_daemon_actions_h () ) (actions |>
daemon_functions |> sort);
List.iter (
- fun { name = name; style = ret, args, optargs } ->
+ fun { name; style = ret, args, optargs } ->
let args_passed_to_daemon = args @ args_of_optargs optargs in
let args_passed_to_daemon List.filter (function String
((FileIn|FileOut), _) -> false | _ -> true)
@@ -83,7 +83,7 @@ let generate_daemon_stubs_h () ";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr "extern void %s_stub (XDR *xdr_in);\n" name;
) (actions |> daemon_functions |> sort);
@@ -117,7 +117,7 @@ let generate_daemon_stubs actions () ";
List.iter (
- fun { name = name; style = ret, args, optargs; optional = optional } ->
+ fun { name; style = ret, args, optargs; optional } ->
(* Generate server-side stubs. *)
let uc_name = String.uppercase_ascii name in
@@ -478,7 +478,7 @@ let generate_daemon_caml_callbacks_ml () pr "let
init_callbacks () =\n";
pr " (* Initialize callbacks to OCaml code. *)\n";
List.iter (
- fun ({ name = name; style = ret, args, optargs } as f) ->
+ fun ({ name; style = ret, args, optargs } as f) ->
let ocaml_function match f.impl with
| OCaml f -> f
@@ -624,7 +624,7 @@ let generate_daemon_caml_stubs ()
(* Implement the wrapper functions. *)
List.iter (
- fun ({ name = name; style = ret, args, optargs } as f) ->
+ fun ({ name; style = ret, args, optargs } as f) ->
let uc_name = String.uppercase_ascii name in
let ocaml_function match f.impl with
@@ -825,7 +825,7 @@ let generate_daemon_dispatch () pr " switch
(proc_nr) {\n";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr " case GUESTFS_PROC_%s:\n" (String.uppercase_ascii name);
pr " %s_stub (xdr_in);\n" name;
pr " break;\n"
@@ -1040,7 +1040,7 @@ let generate_daemon_names () pr "const char
*function_names[] = {\n";
List.iter (
function
- | { name = name; proc_nr = Some proc_nr } ->
+ | { name; proc_nr = Some proc_nr } ->
pr " [%d] = \"%s\",\n" proc_nr name
| { proc_nr = None } -> assert false
) (actions |> daemon_functions |> sort);
@@ -1124,7 +1124,7 @@ let generate_daemon_optgroups_h () pr "#define
OPTGROUP_%s_NOT_AVAILABLE \\\n"
(String.uppercase_ascii group);
List.iter (
- fun { name = name; style = ret, args, optargs } ->
+ fun { name; style = ret, args, optargs } ->
let style = ret, args @ args_of_optargs optargs, [] in
pr " ";
generate_prototype
diff --git a/generator/erlang.ml b/generator/erlang.ml
index a7627cff9..5d5253278 100644
--- a/generator/erlang.ml
+++ b/generator/erlang.ml
@@ -43,7 +43,7 @@ let rec generate_erlang_erl ()
(* Export the public actions. *)
List.iter (
- fun { name = name; style = _, args, optargs; non_c_aliases = aliases }
->
+ fun { name; style = _, args, optargs; non_c_aliases = aliases } ->
let nr_args = List.length args in
let export name if optargs = [] then
@@ -102,7 +102,7 @@ loop(Port) ->
* process which dispatches them to the port.
*)
List.iter (
- fun { name = name; style = _, args, optargs; non_c_aliases = aliases }
->
+ fun { name; style = _, args, optargs; non_c_aliases = aliases } ->
pr "%s(G" name;
List.iter (
fun arg ->
@@ -228,7 +228,7 @@ extern int64_t get_int64 (ETERM *term);
pr "\n";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr "ETERM *run_%s (ETERM *args_tuple);\n" name
) (actions |> external_functions |> sort);
@@ -351,8 +351,8 @@ instead of erl_interface.
(* The wrapper functions. *)
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ c_function; c_optarg_prefix } ->
pr "\n";
pr "ETERM *\n";
pr "run_%s (ETERM *args_tuple)\n" name;
@@ -550,7 +550,7 @@ dispatch (ETERM *args_tuple)
";
List.iter (
- fun { name = name; style = ret, args, optargs } ->
+ fun { name; style = ret, args, optargs } ->
pr "if (atom_equals (fun, \"%s\"))\n" name;
pr " return run_%s (args_tuple);\n" name;
pr " else ";
diff --git a/generator/fish.ml b/generator/fish.ml
index 546cd8ed6..e34022ac5 100644
--- a/generator/fish.ml
+++ b/generator/fish.ml
@@ -53,7 +53,7 @@ let doc_opttype_of = function
| OString n
| OStringList n -> ".."
-let get_aliases { fish_alias = fish_alias; non_c_aliases = non_c_aliases } +let
get_aliases { fish_alias; non_c_aliases } let non_c_aliases List.map
(fun n -> String.replace_char n '_' '-') non_c_aliases in
fish_alias @ non_c_aliases
@@ -61,7 +61,7 @@ let get_aliases { fish_alias = fish_alias; non_c_aliases =
non_c_aliases } let all_functions_commands_and_aliases_sorted let all
List.fold_right (
- fun ({ name = name; shortdesc = shortdesc } as f) acc ->
+ fun ({ name; shortdesc } as f) acc ->
let aliases = get_aliases f in
let aliases = List.filter (
fun x ->
@@ -152,9 +152,8 @@ let generate_fish_run_cmds actions () ) (rstructs_used_by
(actions |> fish_functions));
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- fish_output = fish_output; c_function = c_function;
- c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ fish_output; c_function; c_optarg_prefix } ->
pr "\n";
pr "int\n";
pr "run_%s (const char *cmd, size_t argc, char *argv[])\n"
name;
@@ -509,7 +508,7 @@ let generate_fish_run_header () pr "\n";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr "extern int run_%s (const char *cmd, size_t argc, char
*argv[]);\n"
name
) (actions |> fish_functions |> sort);
@@ -530,8 +529,7 @@ let generate_fish_cmd_entries actions () pr
"\n";
List.iter (
- fun ({ name = name; style = _, args, optargs;
- shortdesc = shortdesc; longdesc = longdesc } as f) ->
+ fun ({ name; style = _, args, optargs; shortdesc; longdesc } as f) ->
let aliases = get_aliases f in
let name2 = String.replace_char name '_' '-' in
@@ -619,7 +617,7 @@ let generate_fish_cmds ()
(* List of command_entry structs for pure guestfish commands. *)
List.iter (
- fun ({ name = name; shortdesc = shortdesc; longdesc = longdesc } as f)
->
+ fun ({ name; shortdesc; longdesc } as f) ->
let aliases = get_aliases f in
let name2 = String.replace_char name '_' '-' in
@@ -677,7 +675,7 @@ and generate_fish_cmds_h () pr "\n";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr "extern int run_%s (const char *cmd, size_t argc, char
*argv[]);\n"
name
) fish_commands;
@@ -712,7 +710,7 @@ and generate_fish_cmds_gperf () ";
List.iter (
- fun { name = name } ->
+ fun { name } ->
pr "extern struct command_entry %s_cmd_entry;\n" name
) fish_functions_and_commands_sorted;
@@ -725,7 +723,7 @@ struct command_table;
";
List.iter (
- fun ({ name = name } as f) ->
+ fun ({ name } as f) ->
let aliases = get_aliases f in
let name2 = String.replace_char name '_' '-' in
@@ -817,7 +815,7 @@ static const char *const commands[] = {
*)
let commands List.map (
- fun ({ name = name } as f) ->
+ fun ({ name } as f) ->
let aliases = get_aliases f in
let name2 = String.replace_char name '_' '-' in
name2 :: aliases
@@ -886,7 +884,7 @@ and generate_fish_actions_pod () let rex = Str.regexp
"C<guestfs_\\([^>]+\\)>" in
List.iter (
- fun ({ name = name; style = _, args, optargs; longdesc = longdesc } as f)
->
+ fun ({ name; style = _, args, optargs; longdesc } as f) ->
let aliases = get_aliases f in
let longdesc @@ -960,7 +958,7 @@ and generate_fish_commands_pod ()
generate_header PODStyle GPLv2plus;
List.iter (
- fun ({ name = name; longdesc = longdesc } as f) ->
+ fun ({ name; longdesc } as f) ->
let aliases = get_aliases f in
let name = String.replace_char name '_' '-' in
diff --git a/generator/golang.ml b/generator/golang.ml
index 67f360839..e2cee51d8 100644
--- a/generator/golang.ml
+++ b/generator/golang.ml
@@ -260,8 +260,7 @@ func return_hashtable (argv **C.char) map[string]string {
(* Actions. *)
List.iter (
- fun ({ name = name; shortdesc = shortdesc;
- style = (ret, args, optargs) } as f) ->
+ fun ({ name; shortdesc; style = (ret, args, optargs) } as f) ->
let go_name = String.capitalize_ascii name in
(* If it has optional arguments, pass them in a struct
diff --git a/generator/haskell.ml b/generator/haskell.ml
index ec3f311df..e304d1a9c 100644
--- a/generator/haskell.ml
+++ b/generator/haskell.ml
@@ -61,7 +61,7 @@ module Guestfs (
(* List out the names of the actions we want to export. *)
List.iter (
- fun { name = name; style = style } ->
+ fun { name; style } ->
if can_generate style then pr ",\n %s" name
) (actions |> external_functions |> sort);
@@ -123,7 +123,7 @@ assocListOfHashtable (a:b:rest) = (a,b) :
assocListOfHashtable rest
(* Generate wrappers for each foreign function. *)
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
+ fun { name; style = (ret, args, optargs as style);
c_function = c_function } ->
if can_generate style then (
pr "foreign import ccall unsafe \"guestfs.h %s\"
c_%s\n"
diff --git a/generator/java.ml b/generator/java.ml
index 94d68c14a..308f65bd8 100644
--- a/generator/java.ml
+++ b/generator/java.ml
@@ -614,7 +614,7 @@ throw_out_of_memory (JNIEnv *env, const char *msg)
";
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
+ fun { name; style = (ret, args, optargs as style);
c_function = c_function } ->
pr "\n";
pr "JNIEXPORT ";
diff --git a/generator/lua.ml b/generator/lua.ml
index c47938c8a..f544ce07a 100644
--- a/generator/lua.ml
+++ b/generator/lua.ml
@@ -431,8 +431,8 @@ guestfs_int_lua_delete_event_callback (lua_State *L)
(* Actions. *)
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ c_function; c_optarg_prefix } ->
pr "static int\n";
pr "guestfs_int_lua_%s (lua_State *L)\n" name;
pr "{\n";
@@ -883,7 +883,7 @@ static luaL_Reg methods[] = {
";
List.iter (
- fun { name = name } -> pr " { \"%s\", guestfs_int_lua_%s
},\n" name name
+ fun { name } -> pr " { \"%s\", guestfs_int_lua_%s
},\n" name name
) (actions |> external_functions |> sort);
pr "\
diff --git a/generator/main.ml b/generator/main.ml
index f4fed4f8b..5d90f0fae 100644
--- a/generator/main.ml
+++ b/generator/main.ml
@@ -40,7 +40,7 @@ let perror msg = function
*)
let nr_actions_files = 7
let actions_subsets - let h i { name = name } = i = Hashtbl.hash name mod
nr_actions_files in
+ let h i { name } = i = Hashtbl.hash name mod nr_actions_files in
Array.init nr_actions_files (fun i -> List.filter (h i) actions)
let output_to_subset fs f for i = 0 to nr_actions_files-1 do
@@ -310,7 +310,7 @@ Run it from the top source directory using the command
delete_except_generated "gobject/src/struct-*.c";
List.iter (
function
- | ({ name = name; style = (_, _, (_::_ as optargs)) } as f) ->
+ | ({ name; style = (_, _, (_::_ as optargs)) } as f) ->
let short = sprintf "optargs-%s" name in
let filename sprintf
"gobject/include/guestfs-gobject/%s.h" short in
diff --git a/generator/perl.ml b/generator/perl.ml
index 8e3dad75e..31a1d194f 100644
--- a/generator/perl.ml
+++ b/generator/perl.ml
@@ -328,8 +328,8 @@ PREINIT:
";
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ c_function; c_optarg_prefix } ->
(match ret with
| RErr -> pr "void\n"
| RInt _ -> pr "SV *\n"
@@ -885,8 +885,7 @@ errnos:
* they are pulled in from the XS code automatically.
*)
List.iter (
- fun ({ name = name; style = style;
- longdesc = longdesc; non_c_aliases = non_c_aliases } as f) ->
+ fun ({ name; style; longdesc; non_c_aliases } as f) ->
let longdesc = String.replace longdesc "C<guestfs_"
"C<$g-E<gt>" in
pr "=item ";
generate_perl_prototype name style;
diff --git a/generator/php.ml b/generator/php.ml
index 3c0ace53a..f42626d01 100644
--- a/generator/php.ml
+++ b/generator/php.ml
@@ -55,7 +55,7 @@ PHP_FUNCTION (guestfs_last_error);
";
List.iter (
- fun { name = name } -> pr "PHP_FUNCTION (guestfs_%s);\n" name
+ fun { name } -> pr "PHP_FUNCTION (guestfs_%s);\n" name
) (actions |> external_functions |> sort);
pr "\
@@ -199,7 +199,7 @@ static zend_function_entry guestfs_php_functions[] = {
";
List.iter (
- fun { name = name } -> pr " PHP_FE (guestfs_%s, NULL)\n" name
+ fun { name } -> pr " PHP_FE (guestfs_%s, NULL)\n" name
) (actions |> external_functions |> sort);
pr " { NULL, NULL, NULL }
@@ -271,7 +271,7 @@ PHP_FUNCTION (guestfs_last_error)
(* Now generate the PHP bindings for each action. *)
List.iter (
fun { name = shortname; style = ret, args, optargs as style;
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ c_function; c_optarg_prefix } ->
pr "PHP_FUNCTION (guestfs_%s)\n" shortname;
pr "{\n";
pr " zval *z_g;\n";
diff --git a/generator/python.ml b/generator/python.ml
index 331367696..796e26aa5 100644
--- a/generator/python.ml
+++ b/generator/python.ml
@@ -121,7 +121,7 @@ extern char *guestfs_int_py_asstring (PyObject *obj);
pr "\n";
List.iter (
- fun { name = name; c_name = c_name } ->
+ fun { name; c_name } ->
pr "#ifdef GUESTFS_HAVE_%s\n" (String.uppercase_ascii c_name);
pr "extern PyObject *guestfs_int_py_%s (PyObject *self, PyObject
*args);\n" name;
pr "#endif\n"
@@ -284,10 +284,8 @@ and generate_python_actions actions () ";
List.iter (
- fun { name = name; style = (ret, args, optargs as style);
- blocking = blocking;
- c_name = c_name;
- c_function = c_function; c_optarg_prefix = c_optarg_prefix } ->
+ fun { name; style = (ret, args, optargs as style);
+ blocking; c_name; c_function; c_optarg_prefix } ->
pr "#ifdef GUESTFS_HAVE_%s\n" (String.uppercase_ascii c_name);
pr "PyObject *\n";
pr "guestfs_int_py_%s (PyObject *self, PyObject *args)\n" name;
@@ -585,7 +583,7 @@ and generate_python_module () pr " { (char *)
\"event_to_string\",\n";
pr " guestfs_int_py_event_to_string, METH_VARARGS, NULL },\n";
List.iter (
- fun { name = name; c_name = c_name } ->
+ fun { name; c_name } ->
pr "#ifdef GUESTFS_HAVE_%s\n" (String.uppercase_ascii c_name);
pr " { (char *) \"%s\", guestfs_int_py_%s, METH_VARARGS,
NULL },\n"
name name;
diff --git a/generator/ruby.ml b/generator/ruby.ml
index f209109ee..308dd589b 100644
--- a/generator/ruby.ml
+++ b/generator/ruby.ml
@@ -492,8 +492,7 @@ Init__guestfs (void)
(* Methods. *)
List.iter (
- fun { name = name; style = _, args, optargs;
- non_c_aliases = non_c_aliases } ->
+ fun { name; style = _, args, optargs; non_c_aliases } ->
let nr_args = if optargs = [] then List.length args else -1 in
pr " rb_define_method (c_guestfs, \"%s\",\n" name;
pr " guestfs_int_ruby_%s, %d);\n" name
nr_args;
diff --git a/generator/tests_c_api.ml b/generator/tests_c_api.ml
index b1681cd09..eafae3368 100644
--- a/generator/tests_c_api.ml
+++ b/generator/tests_c_api.ml
@@ -69,7 +69,7 @@ let rec generate_c_api_tests ()
let hash : (string, bool) Hashtbl.t = Hashtbl.create 13 in
List.iter (
- fun { tests = tests } ->
+ fun { tests } ->
let seqs = filter_map (
function
| (_, (Always|IfAvailable _|IfNotCrossAppliance), test, cleanup) ->
@@ -81,7 +81,7 @@ let rec generate_c_api_tests () ) actions;
List.iter (
- fun { name = name } ->
+ fun { name } ->
if not (Hashtbl.mem hash name) then
pr " \"%s\",\n" name
) (actions |> sort);
@@ -98,7 +98,7 @@ let rec generate_c_api_tests () (* Generate the actual
tests. *)
let test_names List.map (
- fun { name = name; optional = optional; tests = tests } ->
+ fun { name; optional; tests } ->
mapi (generate_one_test name optional) tests
) (actions |> sort) in
let test_names = List.concat test_names in
diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml
index a15582834..03e1a13c1 100644
--- a/get-kernel/get_kernel.ml
+++ b/get-kernel/get_kernel.ml
@@ -100,9 +100,7 @@ read the man page virt-get-kernel(1).
?libvirturi dom)
| Some uri, None ->
fun g ->
- let { URI.path = path; protocol = protocol;
- server = server; username = username;
- password = password } = uri in
+ let { URI.path; protocol; server; username; password } = uri in
let format = match !format with "auto" -> None | s ->
Some s in
g#add_drive
~readonly:true ?format ~protocol ?server ?username ?secret:password
diff --git a/ocaml/t/guestfs_100_launch.ml b/ocaml/t/guestfs_100_launch.ml
index 2e3343794..de8b8b084 100644
--- a/ocaml/t/guestfs_100_launch.ml
+++ b/ocaml/t/guestfs_100_launch.ml
@@ -42,7 +42,7 @@ let () let cmp { Guestfs.name = n1 } { Guestfs.name = n2 }
= compare n1 n2 in
let dirs = List.sort cmp dirs in
let dirs = List.map (
- fun { Guestfs.name = name; Guestfs.ftyp = ftyp } -> (name, ftyp)
+ fun { Guestfs.name; ftyp } -> (name, ftyp)
) dirs in
if dirs <> [ ".", 'd';
diff --git a/resize/resize.ml b/resize/resize.ml
index a19e57564..49fdfd538 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -339,9 +339,7 @@ read the man page virt-resize(1).
* and few additional parameters.
*)
let add_drive_uri (g : Guestfs.guestfs) ?format ?readonly ?cachemode
- { URI.path = path; protocol = protocol;
- server = server; username = username;
- password = password } + { URI.path;
protocol; server; username; password } g#add_drive ?format ?readonly
?cachemode
~protocol ?server ?username ?secret:password path
in
@@ -477,7 +475,7 @@ read the man page virt-resize(1).
let partitions List.map (
- fun ({ G.part_num = part_num } as part) ->
+ fun ({ G.part_num } as part) ->
let part_num = Int32.to_int part_num in
let name = sprintf "/dev/sda%d" part_num in
let bootable = g#part_get_bootable "/dev/sda" part_num in
@@ -536,10 +534,10 @@ read the man page virt-resize(1).
(* Check partitions don't overlap. *)
let rec loop end_of_prev = function
| [] -> ()
- | { p_name = name; p_part = { G.part_start = part_start } } :: _
+ | { p_name = name; p_part = { G.part_start } } :: _
when end_of_prev > part_start ->
error (f_"%s: this partition overlaps the previous one") name
- | { p_part = { G.part_end = part_end } } :: parts -> loop part_end
parts
+ | { p_part = { G.part_end } } :: parts -> loop part_end parts
in
loop 0L partitions;
@@ -1408,7 +1406,7 @@ read the man page virt-resize(1).
(* Try to sync the destination disk only if it is a local file. *)
(match outfile with
- | _, { URI.protocol = (""|"file"); path = path } ->
+ | _, { URI.protocol = (""|"file"); path } ->
(* Because we used cache=unsafe when writing the output file, the
* file might not be committed to disk. This is a problem if qemu is
* immediately used afterwards with cache=none (which uses O_DIRECT
diff --git a/sparsify/utils.ml b/sparsify/utils.ml
index 27723c3a2..facf466a8 100644
--- a/sparsify/utils.ml
+++ b/sparsify/utils.ml
@@ -28,7 +28,7 @@ module G = Guestfs
let is_read_only_lv (g : G.guestfs) let lvs = Array.to_list (g#lvs_full ())
in
let ro_uuids = filter_map (
- fun { G.lv_uuid = lv_uuid; lv_attr = lv_attr } ->
+ fun { G.lv_uuid; lv_attr } ->
if lv_attr.[1] = 'r' then Some lv_uuid else None
) lvs in
fun fs ->
diff --git a/sysprep/main.ml b/sysprep/main.ml
index 634254d41..75aba578b 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -177,9 +177,7 @@ read the man page virt-sysprep(1).
fun g readonly ->
List.iter (
fun (uri, format) ->
- let { URI.path = path; protocol = protocol;
- server = server; username = username;
- password = password } = uri in
+ let { URI.path; protocol; server; username; password } = uri in
let discard = if readonly then None else Some
"besteffort" in
g#add_drive
~readonly ?discard
diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml
index 5c5640c67..1be5941c1 100644
--- a/sysprep/sysprep_operation.ml
+++ b/sysprep/sysprep_operation.ml
@@ -172,7 +172,7 @@ let extra_args () assert !baked;
List.flatten (
- List.map (fun { extra_args = extra_args } ->
+ List.map (fun { extra_args } ->
List.map (fun { extra_argspec = argspec } -> argspec) extra_args
) !all_operations
)
@@ -202,7 +202,7 @@ let dump_pod_options () assert !baked;
let args = List.map (
- fun { name = op_name; extra_args = extra_args } ->
+ fun { name = op_name; extra_args } ->
List.map (fun ea -> op_name, ea) extra_args
) !all_operations in
let args = List.flatten args in
@@ -292,7 +292,7 @@ let perform_operations_on_filesystems ?operations g root
List.iter (
function
- | { name = name; perform_on_filesystems = Some fn } ->
+ | { name; perform_on_filesystems = Some fn } ->
message (f_"Performing %S ...") name;
fn g root side_effects
| { perform_on_filesystems = None } -> ()
@@ -313,7 +313,7 @@ let perform_operations_on_devices ?operations g root
List.iter (
function
- | { name = name; perform_on_devices = Some fn } ->
+ | { name; perform_on_devices = Some fn } ->
message (f_"Performing %S ...") name;
fn g root side_effects
| { perform_on_devices = None } -> ()
diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index 24fd91b6e..d02f2f5cf 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -35,7 +35,7 @@ type t = {
let create ?uid ?gid () = { uid = uid; gid = gid }
-let with_fork { uid = uid; gid = gid } name f +let with_fork { uid; gid } name
f let pid = fork () in
if pid = 0 then (
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index 0be38ec27..5f313b6fb 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -255,7 +255,7 @@ object
| Some name -> name in
let disks = List.map (
- fun ({ href = href; compressed = compressed } as disk) ->
+ fun ({ href; compressed } as disk) ->
let partial if compressed && partial then (
(* We cannot access compressed disk inside the tar;
diff --git a/v2v/output_glance.ml b/v2v/output_glance.ml
index ed7c89878..2f57a67d1 100644
--- a/v2v/output_glance.ml
+++ b/v2v/output_glance.ml
@@ -145,7 +145,7 @@ object
* hints you should import the data disks to Cinder.
*)
iteri (
- fun i { target_file = target_file; target_format = target_format } ->
+ fun i { target_file; target_format } ->
let name if i == 0 then source.s_name
else sprintf "%s-disk%d" source.s_name (i+1) in
diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml
index 021bf42df..6e59f1932 100644
--- a/v2v/output_qemu.ml
+++ b/v2v/output_qemu.ml
@@ -57,7 +57,7 @@ object
| TargetUEFI -> Some (find_uefi_firmware guestcaps.gcaps_arch) in
let secure_boot_required match uefi_firmware with
- | Some { Uefi.flags = flags }
+ | Some { Uefi.flags }
when List.mem Uefi.UEFI_FLAG_SECURE_BOOT_REQUIRED flags -> true
| _ -> false in
(* Currently these are required by secure boot, but in theory they
@@ -85,7 +85,7 @@ object
(match uefi_firmware with
| None -> ()
- | Some { Uefi.code = code } ->
+ | Some { Uefi.code } ->
if secure_boot_required then
arg_list "-global"
["driver=cfi.pflash01";
"property=secure"; "value=on"];
diff --git a/v2v/output_rhv.ml b/v2v/output_rhv.ml
index c3b2294de..ce2d75c1d 100644
--- a/v2v/output_rhv.ml
+++ b/v2v/output_rhv.ml
@@ -240,7 +240,7 @@ object
Create_ovf.create_meta_files output_alloc esd_uuid image_uuids
targets in
List.iter (
- fun ({ target_file = target_file }, meta) ->
+ fun ({ target_file }, meta) ->
let meta_filename = target_file ^ ".meta" in
Changeuid.make_file changeuid_t meta_filename meta
) (List.combine targets metas);
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 5b4214b62..f60b6b4c7 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -142,7 +142,7 @@ object
Create_ovf.create_meta_files output_alloc dd_uuid
vdsm_params.image_uuids targets in
List.iter (
- fun ({ target_file = target_file }, meta) ->
+ fun ({ target_file }, meta) ->
let meta_filename = target_file ^ ".meta" in
let chan = open_out meta_filename in
output_string chan meta;
diff --git a/v2v/utils.ml b/v2v/utils.ml
index 467fd9a12..91c0ed1c8 100644
--- a/v2v/utils.ml
+++ b/v2v/utils.ml
@@ -73,7 +73,7 @@ let find_uefi_firmware guest_arch let rec loop = function
| [] ->
error (f_"cannot find firmware for UEFI guests.\n\nYou probably
need to install OVMF (x86-64), or AAVMF (aarch64)")
- | ({ Uefi.code = code; vars = vars_template } as ret) :: rest ->
+ | ({ Uefi.code; vars = vars_template } as ret) :: rest ->
if Sys.file_exists code && Sys.file_exists vars_template then
ret
else loop rest
in
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 74ba66a3d..355e55440 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -413,7 +413,7 @@ and check_guest_free_space mpstats message
(f_"Checking for sufficient free disk space in the guest");
List.iter (
fun { mp_path = mp;
- mp_statvfs = { G.bfree = bfree; blocks = blocks; bsize = bsize } }
->
+ mp_statvfs = { G.bfree; blocks; bsize } } ->
(* Ignore small filesystems. *)
let total_size = blocks *^ bsize in
if total_size > 100_000_000L then (
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 3/9] ocaml: Make use of Bytes unconditional.
Do not test for the presence of the Bytes module and do not create the
backwards-compat Bytes module replacement if it is not present. Also
we use the ?-safe-strings? option unconditionally.
This requires OCaml >= 4.02.
---
.gitignore | 1 -
common/mlstdutils/Makefile.am | 8 +-------
m4/guestfs_ocaml.m4 | 40 +---------------------------------------
3 files changed, 2 insertions(+), 47 deletions(-)
diff --git a/.gitignore b/.gitignore
index 36a193054..8ce4bf10c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -130,7 +130,6 @@ Makefile.in
/common/mlpcre/pcre_tests
/common/mlprogress/.depend
/common/mlstdutils/.depend
-/common/mlstdutils/bytes.ml
/common/mlstdutils/guestfs_config.ml
/common/mlstdutils/oUnit-*
/common/mlstdutils/std_utils_tests
diff --git a/common/mlstdutils/Makefile.am b/common/mlstdutils/Makefile.am
index f4296daa4..9e90cab13 100644
--- a/common/mlstdutils/Makefile.am
+++ b/common/mlstdutils/Makefile.am
@@ -28,13 +28,7 @@ SOURCES_MLI = \
stringMap.mli \
stringSet.mli
-if HAVE_BYTES_COMPAT_ML
-SOURCES_ML = bytes.ml
-else
-SOURCES_ML -endif
-
-SOURCES_ML += \
+SOURCES_ML = \
guestfs_config.ml \
stringMap.ml \
stringSet.ml \
diff --git a/m4/guestfs_ocaml.m4 b/m4/guestfs_ocaml.m4
index 162ec0dde..b6e4ad22d 100644
--- a/m4/guestfs_ocaml.m4
+++ b/m4/guestfs_ocaml.m4
@@ -88,7 +88,6 @@ OCAML_PKG_gettext=no
OCAML_PKG_libvirt=no
OCAML_PKG_oUnit=no
ounit_is_v2=no
-have_Bytes_module=no
AS_IF([test "x$OCAMLC" != "xno"],[
# Create common/mlgettext/common_gettext.ml gettext functions or stubs.
@@ -105,20 +104,6 @@ AS_IF([test "x$OCAMLC" != "xno"],[
if test "x$OCAML_PKG_oUnit" != "xno"; then
AC_CHECK_OCAML_MODULE(ounit_is_v2,[OUnit.OUnit2],OUnit2,[+oUnit])
fi
-
- # Check if we have the 'Bytes' module. If not (OCaml < 4.02)
then
- # we need to create a compatibility module.
- # AC_CHECK_OCAML_MODULE is a bit broken, so open code this test.
- AC_MSG_CHECKING([for OCaml module Bytes])
- rm -f conftest.ml
- echo 'let s = Bytes.empty' > conftest.ml
- if $OCAMLC -c conftest.ml >&5 2>&5 ; then
- AC_MSG_RESULT([yes])
- have_Bytes_module=yes
- else
- AC_MSG_RESULT([not found])
- have_Bytes_module=no
- fi
])
AM_CONDITIONAL([HAVE_OCAML_PKG_GETTEXT],
[test "x$OCAML_PKG_gettext" != "xno"])
@@ -131,31 +116,8 @@
AC_CHECK_PROG([OCAML_GETTEXT],[ocaml-gettext],[ocaml-gettext],[no])
AM_CONDITIONAL([HAVE_OCAML_GETTEXT],
[test "x$OCAML_PKG_gettext" != "xno"
&& test "x$OCAML_GETTEXT" != "xno"])
-dnl Create the backwards compatibility Bytes module for OCaml < 4.02.
-mkdir -p common/mlstdutils
-rm -f common/mlstdutils/bytes.ml
-AS_IF([test "x$have_Bytes_module" = "xno"],[
- cat > common/mlstdutils/bytes.ml <<EOF
-include String
-let of_string = String.copy
-let to_string = String.copy
-let sub_string = String.sub
-EOF
-
OCAML_BYTES_COMPAT_CMO='$(top_builddir)/common/mlstdutils/bytes.cmo'
- OCAML_BYTES_COMPAT_ML='$(top_builddir)/common/mlstdutils/bytes.ml'
- safe_string_option-],[
- OCAML_BYTES_COMPAT_CMO- OCAML_BYTES_COMPAT_ML-
safe_string_option="-safe-string"
-])
-AC_SUBST([OCAML_BYTES_COMPAT_CMO])
-AC_SUBST([OCAML_BYTES_COMPAT_ML])
-AM_CONDITIONAL([HAVE_BYTES_COMPAT_ML],
- [test "x$OCAML_BYTES_COMPAT_ML" != "x"])
-
dnl Flags we want to pass to every OCaml compiler call.
OCAML_WARN_ERROR="-warn-error CDEFLMPSUVYZX-3"
AC_SUBST([OCAML_WARN_ERROR])
-OCAML_FLAGS="-g -annot $safe_string_option"
+OCAML_FLAGS="-g -annot -safe-string"
AC_SUBST([OCAML_FLAGS])
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 4/9] ocaml: Replace Filename.temp_dir_name with get_temp_dir_name.
This was deprecated and replaced in OCaml >= 4.00.
---
common/mlutils/unix_utils.ml | 2 +-
common/mlutils/unix_utils.mli | 2 +-
sparsify/copying.ml | 2 +-
3 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/common/mlutils/unix_utils.ml b/common/mlutils/unix_utils.ml
index b135bcaee..b27dfde3a 100644
--- a/common/mlutils/unix_utils.ml
+++ b/common/mlutils/unix_utils.ml
@@ -52,7 +52,7 @@ end
module Mkdtemp = struct
external mkdtemp : string -> string =
"guestfs_int_mllib_mkdtemp"
- let temp_dir ?(base_dir = Filename.temp_dir_name) prefix + let temp_dir
?(base_dir = Filename.get_temp_dir_name ()) prefix mkdtemp (Filename.concat
base_dir (prefix ^ "XXXXXX"))
end
diff --git a/common/mlutils/unix_utils.mli b/common/mlutils/unix_utils.mli
index f4f8ca578..bc632be5b 100644
--- a/common/mlutils/unix_utils.mli
+++ b/common/mlutils/unix_utils.mli
@@ -85,7 +85,7 @@ module Mkdtemp : sig
The optional [~base_dir:string] changes the base directory where
to create the new temporary directory; if not specified, the default
- [Filename.temp_dir_name] is used. *)
+ {!Filename.get_temp_dir_name} is used. *)
end
module Realpath : sig
diff --git a/sparsify/copying.ml b/sparsify/copying.ml
index 7d004b550..8e95e7336 100644
--- a/sparsify/copying.ml
+++ b/sparsify/copying.ml
@@ -71,7 +71,7 @@ let run indisk outdisk check_tmpdir compress convert
(* Use TMPDIR or --tmp parameter? *)
let tmp_place match tmp_param with
- | None -> Directory Filename.temp_dir_name (* $TMPDIR or /tmp *)
+ | None -> Directory (Filename.get_temp_dir_name ()) (* $TMPDIR or /tmp
*)
| Some dir when is_directory dir -> Directory dir
| Some dev when is_block_device dev -> Block_device dev
| Some file when String.is_prefix file "prebuilt:" ->
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 5/9] ocaml: Avoid Warning 52 for URI.parse_uri function.
This avoids warning 52 in OCaml code such as:
try URI.parse_uri arg
with Invalid_argument "URI.parse_uri" -> ...
which prints:
Warning 52: Code should not depend on the actual values of
this constructor's arguments. They are only for information
and may change in future versions. (See manual section 8.5)
In the long term we need to change fish/uri.c so that we can throw
proper errors.
---
builder/downloader.ml | 2 +-
builder/sources.ml | 2 +-
common/mltools/URI.ml | 5 +++++
common/mltools/URI.mli | 10 +++++++++-
common/mltools/uri-c.c | 7 +++++--
customize/customize_main.ml | 2 +-
get-kernel/get_kernel.ml | 2 +-
resize/resize.ml | 4 ++--
sysprep/main.ml | 2 +-
9 files changed, 26 insertions(+), 10 deletions(-)
diff --git a/builder/downloader.ml b/builder/downloader.ml
index 3e776fdc2..b1119bae4 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -68,7 +68,7 @@ let rec download t ?template ?progress_bar ?(proxy =
Curl.SystemProxy) uri and download_to t ?(progress_bar = false) ~proxy uri
filename let parseduri try URI.parse_uri uri
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI '%s'. Look for error messages
printed above.")
uri in
diff --git a/builder/sources.ml b/builder/sources.ml
index 93609bef6..d6de15968 100644
--- a/builder/sources.ml
+++ b/builder/sources.ml
@@ -51,7 +51,7 @@ let parse_conf file let k try Some
(URI.parse_uri (List.assoc ("gpgkey", None) fields)) with
| Not_found -> None
- | Invalid_argument "URI.parse_uri" as ex ->
+ | URI.Parse_failed as ex ->
debug "'%s' has invalid gpgkey URI" n;
raise ex in
match k with
diff --git a/common/mltools/URI.ml b/common/mltools/URI.ml
index c143ae2b9..0f51b612b 100644
--- a/common/mltools/URI.ml
+++ b/common/mltools/URI.ml
@@ -24,4 +24,9 @@ type uri = {
password : string option;
}
+exception Parse_failed
+
external parse_uri : string -> uri = "guestfs_int_mllib_parse_uri"
+
+let () + Callback.register_exception "URI.Parse_failed" Parse_failed
diff --git a/common/mltools/URI.mli b/common/mltools/URI.mli
index 0692f955f..1ef941268 100644
--- a/common/mltools/URI.mli
+++ b/common/mltools/URI.mli
@@ -26,5 +26,13 @@ type uri = {
password : string option; (** password *)
}
+exception Parse_failed
+
val parse_uri : string -> uri
-(** See [fish/uri.h]. *)
+(** See [fish/uri.h].
+
+ This can raise {!Parse_failed}.
+
+ Unfortunately we cannot be specific about the actual error
+ (although [fish/uri.c] should print something). XXX We should
+ be able to fetch and throw a real exception with the error. *)
diff --git a/common/mltools/uri-c.c b/common/mltools/uri-c.c
index 3e539c50e..b068c2960 100644
--- a/common/mltools/uri-c.c
+++ b/common/mltools/uri-c.c
@@ -26,6 +26,7 @@
#include <locale.h>
#include <caml/alloc.h>
+#include <caml/callback.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
@@ -45,8 +46,10 @@ guestfs_int_mllib_parse_uri (value argv /* arg value, not an
array! */)
int r;
r = parse_uri (String_val (argv), &uri);
- if (r == -1)
- caml_invalid_argument ("URI.parse_uri");
+ if (r == -1) {
+ value *exn = caml_named_value ("URI.Parse_failed");
+ caml_raise (*exn);
+ }
/* Convert the struct into an OCaml tuple. */
rv = caml_alloc_tuple (5);
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index aad6ebe65..8bd197b83 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -59,7 +59,7 @@ let main () let add_file arg let uri try
URI.parse_uri arg
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI '%s'. Look for error messages
printed above.")
arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml
index 03e1a13c1..10ead853f 100644
--- a/get-kernel/get_kernel.ml
+++ b/get-kernel/get_kernel.ml
@@ -40,7 +40,7 @@ let parse_cmdline () error (f_"--add option can
only be given once");
let uri try URI.parse_uri arg
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI '%s'. Look for error messages
printed above.") arg in
file := Some uri
and set_domain dom diff --git a/resize/resize.ml b/resize/resize.ml
index 49fdfd538..f428f3ebe 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -313,14 +313,14 @@ read the man page virt-resize(1).
(* infile can be a URI. *)
let infile try (infile, URI.parse_uri infile)
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI ?%s?. Look for error messages printed
above.")
infile in
(* outfile can be a URI. *)
let outfile try (outfile, URI.parse_uri outfile)
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI ?%s?. Look for error messages printed
above.")
outfile in
diff --git a/sysprep/main.ml b/sysprep/main.ml
index 75aba578b..3ba0c7b82 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -55,7 +55,7 @@ let main () let add_file arg let uri try
URI.parse_uri arg
- with Invalid_argument "URI.parse_uri" ->
+ with URI.Parse_failed ->
error (f_"error parsing URI ?%s?. Look for error messages
printed above.") arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
push_front (uri, format) files;
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 6/9] ocaml: Avoid Warning 52 for Visit.visit function.
Similar to the previous commit, this creates a new Visit.Failure
exception for the visit function, avoiding Warning 52.
---
common/mlvisit/visit-c.c | 6 ++++--
common/mlvisit/visit.ml | 5 +++++
common/mlvisit/visit.mli | 6 ++++--
common/mlvisit/visit_tests.ml | 10 ++++++----
4 files changed, 19 insertions(+), 8 deletions(-)
diff --git a/common/mlvisit/visit-c.c b/common/mlvisit/visit-c.c
index fcd0428f7..7137c4998 100644
--- a/common/mlvisit/visit-c.c
+++ b/common/mlvisit/visit-c.c
@@ -53,6 +53,7 @@ value
guestfs_int_mllib_visit (value gv, value dirv, value fv)
{
CAMLparam3 (gv, dirv, fv);
+ value *visit_failure_exn;
guestfs_h *g = (guestfs_h *) (intptr_t) Int64_val (gv);
struct visitor_function_wrapper_args args;
/* The dir string could move around when we call the
@@ -81,9 +82,10 @@ guestfs_int_mllib_visit (value gv, value dirv, value fv)
/* Otherwise it's some other failure. The visit function has
* already printed the error to stderr (XXX - fix), so we raise a
- * generic Failure.
+ * generic exception.
*/
- caml_failwith ("visit");
+ visit_failure_exn = caml_named_value ("Visit.Failure");
+ caml_raise (*visit_failure_exn);
}
free (dir);
diff --git a/common/mlvisit/visit.ml b/common/mlvisit/visit.ml
index da2e122ed..4e664f049 100644
--- a/common/mlvisit/visit.ml
+++ b/common/mlvisit/visit.ml
@@ -18,8 +18,13 @@
type visitor_function = string -> string option -> Guestfs.statns ->
Guestfs.xattr array -> unit
+exception Failure
+
external c_visit : int64 -> string -> visitor_function -> unit
"guestfs_int_mllib_visit"
let visit g dir f c_visit (Guestfs.c_pointer g) dir f
+
+let () + Callback.register_exception "Visit.Failure" Failure
diff --git a/common/mlvisit/visit.mli b/common/mlvisit/visit.mli
index cba85785e..85a204937 100644
--- a/common/mlvisit/visit.mli
+++ b/common/mlvisit/visit.mli
@@ -36,6 +36,8 @@ type visitor_function = string -> string option ->
Guestfs.statns -> Guestfs.xat
The visitor callback may raise an exception, which will cause
the whole visit to fail with an error (raising the same exception). *)
+exception Failure
+
val visit : Guestfs.t -> string -> visitor_function -> unit
(** [visit g dir f] calls the [visitor_function f] once for
every directory and every file.
@@ -43,8 +45,8 @@ val visit : Guestfs.t -> string -> visitor_function
-> unit
If the visitor function raises an exception, then the whole visit
stops and raises the same exception.
- Also other errors can happen, and those will cause a [Failure
- "visit"] exception to be raised. (Because of the implementation
+ Also other errors can happen, and those will cause a {!Failure}
+ exception to be raised. (Because of the implementation
of the underlying function, the real error is printed
unconditionally to stderr).
diff --git a/common/mlvisit/visit_tests.ml b/common/mlvisit/visit_tests.ml
index 6753dfb90..30a1669a8 100644
--- a/common/mlvisit/visit_tests.ml
+++ b/common/mlvisit/visit_tests.ml
@@ -25,6 +25,8 @@ open Visit
module G = Guestfs
+exception Test of string
+
let rec main () let g = new G.guestfs () in
g#add_drive_scratch (Int64.mul 1024L (Int64.mul 1024L 1024L));
@@ -107,17 +109,17 @@ let rec main ()
(* Raise an exception in the visitor_function. *)
printf "testing exception in visitor function\n%!";
- (try visit g#ocaml_handle "/" (fun _ _ _ _ -> invalid_arg
"test");
+ (try visit g#ocaml_handle "/" (fun _ _ _ _ -> raise (Test
"test"));
assert false
- with Invalid_argument "test" -> ()
+ with Test "test" -> ()
(* any other exception escapes and kills the test *)
);
- (* Force an error and check [Failure "visit"] is raised. *)
+ (* Force an error and check [Visit.Failure] is raised. *)
printf "testing general error in visit\n%!";
(try visit g#ocaml_handle "/nosuchdir" (fun _ _ _ _ -> ());
assert false
- with Failure "visit" -> ()
+ with Visit.Failure -> ()
(* any other exception escapes and kills the test *)
);
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 7/9] ocaml: Avoid Warning 52 for Planner.plan function.
Change the Planner.plan function so it returns an optional type. This
means it no longer raises Failure "plan" on error, so we can both
force the caller to deal with the error case and avoid Warning 52.
---
builder/builder.ml | 9 ++++-----
common/mltools/planner.ml | 4 ++--
common/mltools/planner.mli | 5 ++---
3 files changed, 8 insertions(+), 10 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index bf3f52f6a..1faf467c0 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -503,11 +503,10 @@ let main () (* Plan how to create the disk image. *)
message (f_"Planning how to build this image");
let plan - try plan ~max_depth:5 transitions itags ~must ~must_not
- with
- Failure "plan" ->
- error (f_"no plan could be found for making a disk image with\nthe
required size, format etc. This is a bug in libguestfs!\nPlease file a bug,
giving the command line arguments you used.");
- in
+ match plan ~max_depth:5 transitions itags ~must ~must_not with
+ | Some plan -> plan
+ | None ->
+ error (f_"no plan could be found for making a disk image with\nthe
required size, format etc. This is a bug in libguestfs!\nPlease file a bug,
giving the command line arguments you used.") in
(* Print out the plan. *)
if verbose () then (
diff --git a/common/mltools/planner.ml b/common/mltools/planner.ml
index 736cfee92..9730df843 100644
--- a/common/mltools/planner.ml
+++ b/common/mltools/planner.ml
@@ -50,7 +50,7 @@ let plan ?(max_depth = 10) transitions itags ~must ~must_not
(* Breadth-first search. *)
let rec search depth paths - if depth >= max_depth then failwith
"plan"
+ if depth >= max_depth then None
else (
let paths List.map (
@@ -76,7 +76,7 @@ let plan ?(max_depth = 10) transitions itags ~must ~must_not
(* Return the shortest path, but we have to reverse it because
* we built it backwards.
*)
- List.rev ret
+ Some (List.rev ret)
)
in
diff --git a/common/mltools/planner.mli b/common/mltools/planner.mli
index 8cd1c51c9..88f9fb2ca 100644
--- a/common/mltools/planner.mli
+++ b/common/mltools/planner.mli
@@ -67,7 +67,7 @@ type ('name, 'value, 'task) transitions_function
val plan : ?max_depth:int -> ('name, 'value, 'task)
transitions_function ->
('name, 'value) tags ->
must: ('name, 'value) tags -> must_not: ('name,
'value) tags ->
- ('name, 'value, 'task) plan
+ ('name, 'value, 'task) plan option
(** Make a plan.
[plan transitions itags goal_must goal_must_not] works out a
@@ -79,5 +79,4 @@ val plan : ?max_depth:int -> ('name, 'value,
'task) transitions_function ->
The returned value is a {!plan}.
- Raises [Failure "plan"] if no plan was found within [max_depth]
- transitions. *)
+ Returns [None] if no plan was found within [max_depth] transitions. *)
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 8/9] ocaml: Enable warn-error on warning 52.
Since the previous commits have fixed all instances of this warning,
it should now be safe to enable warn-error on it.
---
m4/guestfs_ocaml.m4 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/m4/guestfs_ocaml.m4 b/m4/guestfs_ocaml.m4
index b6e4ad22d..acb6a9fd5 100644
--- a/m4/guestfs_ocaml.m4
+++ b/m4/guestfs_ocaml.m4
@@ -117,7 +117,7 @@ AM_CONDITIONAL([HAVE_OCAML_GETTEXT],
[test "x$OCAML_PKG_gettext" != "xno"
&& test "x$OCAML_GETTEXT" != "xno"])
dnl Flags we want to pass to every OCaml compiler call.
-OCAML_WARN_ERROR="-warn-error CDEFLMPSUVYZX-3"
+OCAML_WARN_ERROR="-warn-error CDEFLMPSUVYZX+52-3"
AC_SUBST([OCAML_WARN_ERROR])
OCAML_FLAGS="-g -annot -safe-string"
AC_SUBST([OCAML_FLAGS])
--
2.13.2
Richard W.M. Jones
2017-Oct-04 12:56 UTC
[Libguestfs] [PATCH 9/9] ocaml: Use match + exception case in a few places.
In OCaml >= 4.02, match can catch exceptions.
Old code looks like:
try
match expr with
| patt1 -> (* handle patt1 *)
| patt2 -> ...
with
exn -> (* handle exception *)
New code looks like:
match expr with
| patt1 -> (* handle patt1 *)
| patt2 -> ...
| exception exn -> (* handle exception *)
*NB* These are not exactly equivalent, since in the old code an
exception thrown in the ?(* handle patt1 *)? code would be caught by
the exception handler, but this does NOT happen in the new code.
Therefore caution is advised when rewriting code.
See also:
https://blog.janestreet.com/pattern-matching-and-exception-handling-unite/
---
builder/sources.ml | 30 ++++++++++++------------------
common/mlstdutils/std_utils.ml | 8 +++-----
daemon/inspect_fs_unix_fstab.ml | 10 ++++------
daemon/inspect_utils.ml | 18 ++++++------------
v2v/parse_vmx.ml | 10 ++++------
5 files changed, 29 insertions(+), 47 deletions(-)
diff --git a/builder/sources.ml b/builder/sources.ml
index d6de15968..2710b5203 100644
--- a/builder/sources.ml
+++ b/builder/sources.ml
@@ -64,25 +64,19 @@ let parse_conf file Utils.No_Key
) in
let proxy - try
- (match (List.assoc ("proxy", None) fields) with
- | "no" | "off" -> Curl.UnsetProxy
- | "system" -> Curl.SystemProxy
- | _ as proxy -> Curl.ForcedProxy proxy
- )
- with
- Not_found -> Curl.SystemProxy in
+ match List.assoc ("proxy", None) fields with
+ | "no" | "off" -> Curl.UnsetProxy
+ | "system" -> Curl.SystemProxy
+ | _ as proxy -> Curl.ForcedProxy proxy
+ | exception Not_found -> Curl.SystemProxy in
let format - try
- (match (List.assoc ("format", None) fields) with
- | "native" | "" -> FormatNative
- | "simplestreams" -> FormatSimpleStreams
- | fmt ->
- debug "unknown repository type '%s' in %s, skipping
it" fmt file;
- invalid_arg fmt
- )
- with
- Not_found -> FormatNative in
+ match List.assoc ("format", None) fields with
+ | "native" | "" -> FormatNative
+ | "simplestreams" -> FormatSimpleStreams
+ | fmt ->
+ debug "unknown repository type '%s' in %s, skipping
it" fmt file;
+ invalid_arg fmt
+ | exception Not_found -> FormatNative in
{
name = n; uri = uri; gpgkey = gpgkey; proxy = proxy;
format = format;
diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index 37eef0348..0f691db0d 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -600,11 +600,9 @@ let may f = function
type ('a, 'b) maybe = Either of 'a | Or of 'b
let protect ~f ~finally - let r - try Either (f ())
- with exn -> Or exn in
- finally ();
- match r with Either ret -> ret | Or exn -> raise exn
+ match f () with
+ | ret -> finally (); ret
+ | exception exn -> finally (); raise exn
let failwithf fs = ksprintf failwith fs
diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml
index e3c7fd1cd..16c5d5e7c 100644
--- a/daemon/inspect_fs_unix_fstab.ml
+++ b/daemon/inspect_fs_unix_fstab.ml
@@ -317,13 +317,11 @@ and resolve_fstab_device spec md_map os_type * This
makes it impossible to reverse those paths directly, so
* we have implemented lvm_canonical_lv_name in the daemon.
*)
- try
- match Lvm.lv_canonical spec with
- | None -> Mountable.of_device spec
- | Some device -> Mountable.of_device device
- with
+ match Lvm.lv_canonical spec with
+ | None -> Mountable.of_device spec
+ | Some device -> Mountable.of_device device
(* Ignore devices that don't exist. (RHBZ#811872) *)
- | Unix.Unix_error (Unix.ENOENT, _, _) -> default
+ | exception Unix.Unix_error (Unix.ENOENT, _, _) -> default
)
else if PCRE.matches re_xdev spec then (
diff --git a/daemon/inspect_utils.ml b/daemon/inspect_utils.ml
index ef45ba9ee..94f728e3c 100644
--- a/daemon/inspect_utils.ml
+++ b/daemon/inspect_utils.ml
@@ -129,20 +129,14 @@ and aug_rm_noerrors aug path with Augeas.Error _ ->
0
let is_file_nocase path - let path - try Some (Realpath.case_sensitive_path
path)
- with _ -> None in
- match path with
- | None -> false
- | Some path -> Is.is_file path
+ match Realpath.case_sensitive_path path with
+ | path -> Is.is_file path
+ | exception _ -> false
and is_dir_nocase path - let path - try Some (Realpath.case_sensitive_path
path)
- with _ -> None in
- match path with
- | None -> false
- | Some path -> Is.is_dir path
+ match Realpath.case_sensitive_path path with
+ | path -> Is.is_dir path
+ | exception _ -> false
(* Rather hairy test for "is a partition", taken directly from
* the old C inspection code. XXX fix function and callers
diff --git a/v2v/parse_vmx.ml b/v2v/parse_vmx.ml
index 3c72527b9..2b8a86a14 100644
--- a/v2v/parse_vmx.ml
+++ b/v2v/parse_vmx.ml
@@ -338,12 +338,10 @@ and insert vmx value = function
StringMap.add k (Key value) vmx
| ns :: path ->
let v - try
- (match StringMap.find ns vmx with
- | Namespace vmx -> Some vmx
- | Key _ -> None
- )
- with Not_found -> None in
+ match StringMap.find ns vmx with
+ | Namespace vmx -> Some vmx
+ | Key _ -> None
+ | exception Not_found -> None in
let v match v with
| None ->
--
2.13.2
Pino Toscano
2017-Oct-04 16:22 UTC
Re: [Libguestfs] [PATCH 2/9] ocaml: Replace pattern matching { field = field } with { field }.
On Wednesday, 4 October 2017 14:56:23 CEST Richard W.M. Jones wrote:> If you have a struct containing ‘field’, eg: > > type t = { field : int } > > then previously to pattern-match on this type, eg. in function > parameters, you had to write: > > let f { field = field } > (* ... use field ... *) > > In OCaml >= 3.12 it is possible to abbreviate cases where the field > being matched and the variable being bound have the same name, so now > you can just write: > > let f { field } > (* ... use field ... *) > > (Similarly for a field prefixed by a Module name you can use > ‘{ Module.field }’ instead of ‘{ Module.field = field }’). > > This style is widely used inside the OCaml compiler sources, and is > briefer than the long form, so it makes sense to use it. Furthermore > there was one place in virt-dib where we are already using this new > style, so the old code did not compile on OCaml < 3.12.Oops, sorry. Considering it was not reported so far, I guess we do not have many users left on old OCaml versions (old distros, actually). OOC, did you use a script to detect all these occurrences, or did you just manually scan through the code?> diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml > index 5c5640c67..1be5941c1 100644 > --- a/sysprep/sysprep_operation.ml > +++ b/sysprep/sysprep_operation.ml > @@ -172,7 +172,7 @@ let extra_args () > assert !baked; > > List.flatten ( > - List.map (fun { extra_args = extra_args } -> > + List.map (fun { extra_args } -> > List.map (fun { extra_argspec = argspec } -> argspec) extra_argsThe last line here can be also simplified too? -- Pino Toscano
Pino Toscano
2017-Oct-04 16:22 UTC
Re: [Libguestfs] [PATCH 0/9] build: Require OCaml >= 4.02.
On Wednesday, 4 October 2017 14:56:21 CEST Richard W.M. Jones wrote:> Per my previous email: > https://www.redhat.com/archives/libguestfs/2017-September/msg00203.html > I'd like to talk about requiring a more modern version of the OCaml > compiler. > > These commits show some of the code changes which would be possible > with OCaml >= 3.12 [which it turns out we already require by accident] > and also with OCaml >= 4.02. The latter is my favoured option.For sure, IMHO we can raise the OCaml requirement to >= 4.01: it would be a first step, and there are various things that can be used already with that version: - the { field } matching style (your patch #2) - the new Filename methods (your patch #4) - dropping some of the stuff in Std_utils, e.g. iteri, mapi, and (|>) - Unix.O_CLOEXEC instead of Unix.set_close_on_exec So I'd say: - ACK to patch #1, changed to 4.01 - ACK (after fixes following my comments) to patch #2 - ACK to patches #4, #5, #6, #7, and #8 -- Pino Toscano
Seemingly Similar Threads
- [PATCH] generator: Add visibility to action struct
- [PATCH] generator: Share Common_utils code.
- [PATCH 0/9] build: Require OCaml >= 4.02.
- [PATCH 1/3] gobject: generate deprecation markers
- Re: [PATCH 08/11] Rust bindings: Fix memory management and format the file