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

On Wed, Oct 04, 2017 at 06:22:18PM +0200, Pino Toscano wrote: I grepped the code for /{.*;/ and manually rewrote those where appropriate. Not directly, but it could become: - List.map (fun { extra_argspec = argspec } -> argspec) extra_args + List.map (fun { extra_argspec } -> extra_argspec) extra_args which is slightly shorter. I'll adjust this before pushing it. Thanks, Rich. -- Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones Read my programming and virtualization blog: http://rwmj.wordpress.com virt-p2v converts physical machines to virtual machines. Boot with a live CD or over the network (PXE) and turn machines into KVM guests. http://libguestfs.org/virt-v2v

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

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

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