diff --git a/configure.ml b/configure.ml index cfd797beb6b..e5c37d55fbc 100644 --- a/configure.ml +++ b/configure.ml @@ -84,11 +84,12 @@ let () = in List.iter print_endline lines ; (* Expand @LIBEXEC@ in udev rules *) - try - let xenopsd_libexecdir = Hashtbl.find config "XENOPSD_LIBEXECDIR" in - expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" - "ocaml/xenopsd/scripts/vif" ; - expand "@LIBEXEC@" xenopsd_libexecdir - "ocaml/xenopsd/scripts/xen-backend.rules.in" - "ocaml/xenopsd/scripts/xen-backend.rules" - with Not_found -> failwith "xenopsd_libexecdir not set" + match Hashtbl.find_opt config "XENOPSD_LIBEXECDIR" with + | Some xenopsd_libexecdir -> + expand "@LIBEXEC@" xenopsd_libexecdir "ocaml/xenopsd/scripts/vif.in" + "ocaml/xenopsd/scripts/vif" ; + expand "@LIBEXEC@" xenopsd_libexecdir + "ocaml/xenopsd/scripts/xen-backend.rules.in" + "ocaml/xenopsd/scripts/xen-backend.rules" + | None -> + failwith "xenopsd_libexecdir not set" diff --git a/ocaml/database/db_backend.ml b/ocaml/database/db_backend.ml index c5270f68169..92954540c33 100644 --- a/ocaml/database/db_backend.ml +++ b/ocaml/database/db_backend.ml @@ -104,8 +104,5 @@ let is_session_registered session = let get_registered_database session = with_lock db_registration_mutex (fun () -> - if Hashtbl.mem foreign_databases session then - Some (Hashtbl.find foreign_databases session) - else - None + Hashtbl.find_opt foreign_databases session ) diff --git a/ocaml/database/db_conn_store.ml b/ocaml/database/db_conn_store.ml index 0bf1536649e..035020695a0 100644 --- a/ocaml/database/db_conn_store.ml +++ b/ocaml/database/db_conn_store.ml @@ -41,12 +41,14 @@ let read_db_connections () = !db_connections let with_db_conn_lock db_conn f = let db_conn_m = with_lock db_conn_locks_m (fun () -> - try Hashtbl.find db_conn_locks db_conn - with _ -> - (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) - let new_dbconn_mutex = Mutex.create () in - Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; - new_dbconn_mutex + match Hashtbl.find_opt db_conn_locks db_conn with + | Some x -> + x + | None -> + (* If we don't have a lock already for this connection then go make one dynamically and use that from then on *) + let new_dbconn_mutex = Mutex.create () in + Hashtbl.replace db_conn_locks db_conn new_dbconn_mutex ; + new_dbconn_mutex ) in with_lock db_conn_m (fun () -> f ()) diff --git a/ocaml/database/stats.ml b/ocaml/database/stats.ml index 8e7711810c8..8bf4f55de4d 100644 --- a/ocaml/database/stats.ml +++ b/ocaml/database/stats.ml @@ -77,10 +77,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' diff --git a/ocaml/idl/dtd_backend.ml b/ocaml/idl/dtd_backend.ml index da448043c39..d820e2623ef 100644 --- a/ocaml/idl/dtd_backend.ml +++ b/ocaml/idl/dtd_backend.ml @@ -110,14 +110,13 @@ let rec strings_of_dtd_element known_els = function let element known_els name children atts = let existing_children = - if Hashtbl.mem known_els name then - match Hashtbl.find known_els name with - | Element (_, c, att) -> - (c, att) - | _ -> - assert false - else - ([], []) + match Hashtbl.find_opt known_els name with + | Some (Element (_, c, att)) -> + (c, att) + | None -> + ([], []) + | _ -> + assert false in let open Xapi_stdext_std.Listext in let el = diff --git a/ocaml/libs/http-lib/http_svr.ml b/ocaml/libs/http-lib/http_svr.ml index c27f59a7949..217bbc6d19d 100644 --- a/ocaml/libs/http-lib/http_svr.ml +++ b/ocaml/libs/http-lib/http_svr.ml @@ -660,8 +660,11 @@ exception Socket_not_found (* Stop an HTTP server running on a socket *) let stop (socket, _name) = let server = - try Hashtbl.find socket_table socket - with Not_found -> raise Socket_not_found + match Hashtbl.find_opt socket_table socket with + | Some x -> + x + | None -> + raise Socket_not_found in Hashtbl.remove socket_table socket ; server.Server_io.shutdown () diff --git a/ocaml/libs/http-lib/mime.ml b/ocaml/libs/http-lib/mime.ml index c48599c65ad..e8dabaca132 100644 --- a/ocaml/libs/http-lib/mime.ml +++ b/ocaml/libs/http-lib/mime.ml @@ -42,7 +42,7 @@ let default_mime = "text/plain" (** Map a file extension to a MIME type *) let mime_of_ext mime ext = - try Hashtbl.find mime (lowercase ext) with Not_found -> default_mime + Option.value (Hashtbl.find_opt mime (lowercase ext)) ~default:default_mime (** Figure out a mime type from a full filename *) let mime_of_file_name mime fname = diff --git a/ocaml/libs/resources/table.ml b/ocaml/libs/resources/table.ml index 9c284f80de8..35aa88082ca 100644 --- a/ocaml/libs/resources/table.ml +++ b/ocaml/libs/resources/table.ml @@ -41,7 +41,7 @@ struct Hashtbl.remove t k ) - let find (t, m) k = with_lock m (fun () -> Hashtbl.find t k) + let find (t, m) k = with_lock m (fun () -> Hashtbl.find_opt t k) let with_find_moved_exn (t, m) k = let v = diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index aaaf3dd7d2a..7003efe2d9f 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -35,27 +35,38 @@ let stunnel_logger = ref ignore let timeoutidle = ref None let init_stunnel_path () = - try cached_stunnel_path := Some (Unix.getenv "XE_STUNNEL") - with Not_found -> - let choices = - [ - "/opt/xensource/libexec/stunnel/stunnel" - ; "/usr/sbin/stunnel4" - ; "/usr/sbin/stunnel" - ; "/usr/bin/stunnel4" - ; "/usr/bin/stunnel" - ] - in - let rec choose l = - match l with - | [] -> - raise Stunnel_binary_missing - | p :: ps -> ( - try Unix.access p [Unix.X_OK] ; p with _ -> choose ps + cached_stunnel_path := + Some + ( match Sys.getenv_opt "XE_STUNNEL" with + | Some x -> + x + | None -> + let choices = + [ + "/opt/xensource/libexec/stunnel/stunnel" + ; "/usr/sbin/stunnel4" + ; "/usr/sbin/stunnel" + ; "/usr/bin/stunnel4" + ; "/usr/bin/stunnel" + ] + in + + let choose l = + match + List.find_opt + (fun el -> + try Unix.access el [Unix.X_OK] ; true with _ -> false + ) + l + with + | Some p -> + p + | None -> + raise Stunnel_binary_missing + in + let path = choose choices in + path ) - in - let path = choose choices in - cached_stunnel_path := Some path let stunnel_path () = if Option.is_none !cached_stunnel_path then @@ -150,7 +161,8 @@ let debug_conf_of_bool verbose : string = if verbose then "debug=authpriv.7" else "debug=authpriv.5" let debug_conf_of_env () : string = - (try Unix.getenv "debug_stunnel" with _ -> "") |> String.lowercase_ascii + Option.value (Sys.getenv_opt "debug_stunnel") ~default:"" + |> String.lowercase_ascii |> fun x -> List.mem x ["yes"; "true"; "1"] |> debug_conf_of_bool let config_file ?(accept = None) config host port = diff --git a/ocaml/libs/stunnel/stunnel_cache.ml b/ocaml/libs/stunnel/stunnel_cache.ml index eaf85be89a0..36d986b89c3 100644 --- a/ocaml/libs/stunnel/stunnel_cache.ml +++ b/ocaml/libs/stunnel/stunnel_cache.ml @@ -74,10 +74,13 @@ let unlocked_gc () = ( if debug_enabled then let now = Unix.gettimeofday () in let string_of_id id = - let stunnel = Tbl.find !stunnels id in - Printf.sprintf "(id %s / idle %.2f age %.2f)" (id_of_stunnel stunnel) - (now -. Hashtbl.find !times id) - (now -. stunnel.Stunnel.connected_time) + match (Tbl.find !stunnels id, Hashtbl.find_opt !times id) with + | Some stunnel, Some stunnel_id -> + Printf.sprintf "(id %s / idle %.2f age %.2f)" + (id_of_stunnel stunnel) (now -. stunnel_id) + (now -. stunnel.Stunnel.connected_time) + | _ -> + Printf.sprintf "%s: found no entry for id=%d" __FUNCTION__ id in let string_of_endpoint ep = Printf.sprintf "%s:%d" ep.host ep.port in let string_of_index ep xs = @@ -134,11 +137,15 @@ let unlocked_gc () = let oldest_ids = List.map fst oldest in List.iter (fun x -> - let stunnel = Tbl.find !stunnels x in - debug - "Expiring stunnel id %s since we have too many cached tunnels (limit \ - is %d)" - (id_of_stunnel stunnel) max_stunnel + match Tbl.find !stunnels x with + | Some stunnel -> + debug + "Expiring stunnel id %s since we have too many cached tunnels \ + (limit is %d)" + (id_of_stunnel stunnel) max_stunnel + | None -> + debug "%s: Couldn't find an expiring stunnel (id=%d) in the table" + __FUNCTION__ x ) oldest_ids ; to_gc := !to_gc @ oldest_ids @@ -146,8 +153,8 @@ let unlocked_gc () = (* Disconnect all stunnels we wish to GC *) List.iter (fun id -> - let s = Tbl.find !stunnels id in - Stunnel.disconnect s + (* Only remove stunnel if we find it in the table *) + Option.iter (fun s -> Stunnel.disconnect s) (Tbl.find !stunnels id) ) !to_gc ; (* Remove all reference to them from our cache hashtables *) @@ -187,12 +194,7 @@ let add (x : Stunnel.t) = ; verified= x.Stunnel.verified } in - let existing = - if Hashtbl.mem !index ep then - Hashtbl.find !index ep - else - [] - in + let existing = Option.value (Hashtbl.find_opt !index ep) ~default:[] in Hashtbl.replace !index ep (idx :: existing) ; debug "Adding stunnel id %s (idle %.2f) to the cache" (id_of_stunnel x) 0. ; unlocked_gc () @@ -206,23 +208,33 @@ let with_remove ~host ~port verified f = let get_id () = with_lock m (fun () -> unlocked_gc () ; - let ids = Hashtbl.find !index ep in - let table = List.map (fun id -> (id, Hashtbl.find !times id)) ids in + let ( let* ) = Option.bind in + let* ids = Hashtbl.find_opt !index ep in + let table = + List.filter_map + (fun id -> + Option.map (fun time -> (id, time)) (Hashtbl.find_opt !times id) + ) + ids + in let sorted = List.sort (fun a b -> compare (snd a) (snd b)) table in match sorted with | (id, time) :: _ -> - let stunnel = Tbl.find !stunnels id in - debug "Removing stunnel id %s (idle %.2f) from the cache" - (id_of_stunnel stunnel) - (Unix.gettimeofday () -. time) ; + Option.iter + (fun stunnel -> + debug "Removing stunnel id %s (idle %.2f) from the cache" + (id_of_stunnel stunnel) + (Unix.gettimeofday () -. time) + ) + (Tbl.find !stunnels id) ; Hashtbl.remove !times id ; Hashtbl.replace !index ep (List.filter (fun x -> x <> id) ids) ; - id + Some id | _ -> - raise Not_found + None ) in - let id_opt = try Some (get_id ()) with Not_found -> None in + let id_opt = get_id () in id_opt |> Option.map @@ fun id -> (* cannot call while holding above mutex or we deadlock *) diff --git a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml index 02d9b32d456..458c0c7cce6 100644 --- a/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml +++ b/ocaml/libs/vhd/vhd_format_lwt_test/parse_test.ml @@ -173,12 +173,13 @@ let initial = {to_close= []; to_unlink= []; child= None; contents= []} let sectors = Hashtbl.create 16 let sector_lookup message = - if Hashtbl.mem sectors message then - Hashtbl.find sectors message - else - let data = fill_sector_with message in - Hashtbl.replace sectors message data ; - data + match Hashtbl.find_opt sectors message with + | Some x -> + x + | None -> + let data = fill_sector_with message in + Hashtbl.replace sectors message data ; + data let execute state = function | Create size -> diff --git a/ocaml/libs/xapi-inventory/lib/inventory.ml b/ocaml/libs/xapi-inventory/lib/inventory.ml index 374780a09f8..867d4a2483e 100644 --- a/ocaml/libs/xapi-inventory/lib/inventory.ml +++ b/ocaml/libs/xapi-inventory/lib/inventory.ml @@ -116,14 +116,16 @@ exception Missing_inventory_key of string let lookup ?default key = M.execute inventory_m (fun () -> if not !loaded_inventory then read_inventory_contents () ; - if Hashtbl.mem inventory key then - Hashtbl.find inventory key - else + match Hashtbl.find_opt inventory key with + | Some x -> + x + | None -> ( match default with | None -> raise (Missing_inventory_key key) | Some v -> v + ) ) let flush_to_disk_locked () = diff --git a/ocaml/message-switch/core/make.ml b/ocaml/message-switch/core/make.ml index 224012909ac..43b7e301a9b 100644 --- a/ocaml/message-switch/core/make.ml +++ b/ocaml/message-switch/core/make.ml @@ -189,14 +189,14 @@ functor (fun (i, m) -> M.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> let rec loop events_conn = Connection.rpc events_conn (In.Ack i) >>= function | Ok (_ : string) -> - M.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - return (Ok ()) + M.Ivar.fill x (Ok m) ; return (Ok ()) | Error _ -> reconnect () >>|= fun (requests_conn, events_conn) -> @@ -205,7 +205,7 @@ functor loop events_conn in loop events_conn - else ( + | None -> Printf.printf "no wakener for id %s, %Ld\n%!" (fst i) (snd i) ; Hashtbl.iter @@ -216,7 +216,7 @@ functor ) wakener ; return (Ok ()) - ) + ) | Message.Request _ -> return (Ok ()) ) diff --git a/ocaml/message-switch/switch/mswitch.ml b/ocaml/message-switch/switch/mswitch.ml index fe57a978382..b674ae65059 100644 --- a/ocaml/message-switch/switch/mswitch.ml +++ b/ocaml/message-switch/switch/mswitch.ml @@ -65,10 +65,7 @@ end let next_transfer_expected : (string, int64) Hashtbl.t = Hashtbl.create 128 let get_next_transfer_expected name = - if Hashtbl.mem next_transfer_expected name then - Some (Hashtbl.find next_transfer_expected name) - else - None + Hashtbl.find_opt next_transfer_expected name let record_transfer time name = Hashtbl.replace next_transfer_expected name time diff --git a/ocaml/message-switch/unix/protocol_unix.ml b/ocaml/message-switch/unix/protocol_unix.ml index 485964a40ec..a9b4984e4f4 100644 --- a/ocaml/message-switch/unix/protocol_unix.ml +++ b/ocaml/message-switch/unix/protocol_unix.ml @@ -294,17 +294,17 @@ module Client = struct (* If the Ack doesn't belong to us then assume it's another thread *) IO.Mutex.with_lock requests_m (fun () -> match m.Message.kind with - | Message.Response j -> - if Hashtbl.mem wakener j then ( + | Message.Response j -> ( + match Hashtbl.find_opt wakener j with + | Some x -> do_rpc t.events_conn (In.Ack i) >>|= fun (_ : string) -> - IO.Ivar.fill (Hashtbl.find wakener j) (Ok m) ; - Ok () - ) else ( + IO.Ivar.fill x (Ok m) ; Ok () + | None -> Printf.printf "no wakener for id %s,%Ld\n%!" (fst i) (snd i) ; Ok () - ) + ) | Message.Request _ -> Ok () ) diff --git a/ocaml/networkd/bin/network_monitor_thread.ml b/ocaml/networkd/bin/network_monitor_thread.ml index 7ec920f329c..43b471be21a 100644 --- a/ocaml/networkd/bin/network_monitor_thread.ml +++ b/ocaml/networkd/bin/network_monitor_thread.ml @@ -63,43 +63,41 @@ let send_bond_change_alert _dev interfaces message = let check_for_changes ~(dev : string) ~(stat : Network_monitor.iface_stats) = let open Network_monitor in match Astring.String.is_prefix ~affix:"vif" dev with - | true -> - () - | false -> - if stat.nb_links > 1 then - if (* It is a bond. *) - Hashtbl.mem bonds_status dev then ( - (* Seen before. *) - let nb_links_old, links_up_old = Hashtbl.find bonds_status dev in - if links_up_old <> stat.links_up then ( - info "Bonds status changed: %s nb_links %d up %d up_old %d" dev - stat.nb_links stat.links_up links_up_old ; - Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; - let msg = - Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up - stat.nb_links links_up_old nb_links_old - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) - ) - ) else ( - (* Seen for the first time. *) - Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; - info "New bonds status: %s nb_links %d up %d" dev stat.nb_links - stat.links_up ; - if stat.links_up <> stat.nb_links then - let msg = - Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links - in - try send_bond_change_alert dev stat.interfaces msg - with e -> - debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" - (Printexc.to_string e) - (Printexc.get_backtrace ()) + | false when stat.nb_links > 1 -> ( + (* It is a bond. *) + match Hashtbl.find_opt bonds_status dev with + | Some (nb_links_old, links_up_old) -> + (* Seen before. *) + if links_up_old <> stat.links_up then ( + info "Bonds status changed: %s nb_links %d up %d up_old %d" dev + stat.nb_links stat.links_up links_up_old ; + Hashtbl.replace bonds_status dev (stat.nb_links, stat.links_up) ; + let msg = + Printf.sprintf "changed: %d/%d up (was %d/%d)" stat.links_up + stat.nb_links links_up_old nb_links_old + in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) ) + | None -> ( + (* Seen for the first time. *) + Hashtbl.add bonds_status dev (stat.nb_links, stat.links_up) ; + info "New bonds status: %s nb_links %d up %d" dev stat.nb_links + stat.links_up ; + if stat.links_up <> stat.nb_links then + let msg = Printf.sprintf "is: %d/%d up" stat.links_up stat.nb_links in + try send_bond_change_alert dev stat.interfaces msg + with e -> + debug "Error while sending alert BONDS_STATUS_CHANGED: %s\n%s" + (Printexc.to_string e) + (Printexc.get_backtrace ()) + ) + ) + | _ -> + () let failed_again = ref false diff --git a/ocaml/networkd/lib/network_utils.ml b/ocaml/networkd/lib/network_utils.ml index 1c7479e83e5..fe371e694de 100644 --- a/ocaml/networkd/lib/network_utils.ml +++ b/ocaml/networkd/lib/network_utils.ml @@ -112,7 +112,11 @@ let check_n_run ?(on_error = default_error_handler) ?(log = true) run_func try Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) - let env = [|"PATH=" ^ Sys.getenv "PATH"|] in + let env = + Option.fold ~none:[||] + ~some:(fun p -> [|"PATH=" ^ p|]) + (Sys.getenv_opt "PATH") + in if log then info "%s %s" script (String.concat " " args) ; run_func env script args diff --git a/ocaml/perftest/tests.ml b/ocaml/perftest/tests.ml index 5262d4be0ec..d0463e9f60a 100644 --- a/ocaml/perftest/tests.ml +++ b/ocaml/perftest/tests.ml @@ -112,13 +112,13 @@ let parallel_with_vms async_op opname n vms rpc session_id test subtest_name = List.iter (fun task -> if List.mem task !active_tasks then ( - ( if not (Hashtbl.mem tasks_to_vm task) then + ( match Hashtbl.find_opt tasks_to_vm task with + | None -> debug ~out:stderr "Ignoring completed task which doesn't correspond to a \ VM %s" opname - else - let uuid = Hashtbl.find tasks_to_vm task in + | Some uuid -> let started = Hashtbl.find vm_to_start_time uuid in let time_taken = Unix.gettimeofday () -. started in results := time_taken :: !results ; diff --git a/ocaml/rrd2csv/src/rrd2csv.ml b/ocaml/rrd2csv/src/rrd2csv.ml index 4e36e581e5b..13fdef256c4 100644 --- a/ocaml/rrd2csv/src/rrd2csv.ml +++ b/ocaml/rrd2csv/src/rrd2csv.ml @@ -110,30 +110,32 @@ let vm_uuid_to_name_label_map = Hashtbl.create 20 let host_uuid_to_name_label_map = Hashtbl.create 10 let get_vm_name_label vm_uuid = - if Hashtbl.mem vm_uuid_to_name_label_map vm_uuid then - Hashtbl.find vm_uuid_to_name_label_map vm_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) - () - in - Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; - name_label + match Hashtbl.find_opt vm_uuid_to_name_label_map vm_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> XAPI.get_vm_name_label ~session_id ~uuid:vm_uuid) + () + in + Hashtbl.replace vm_uuid_to_name_label_map vm_uuid name_label ; + name_label let get_host_name_label host_uuid = - if Hashtbl.mem host_uuid_to_name_label_map host_uuid then - Hashtbl.find host_uuid_to_name_label_map host_uuid - else - let name_label, _session_id = - XAPI.retry_with_session - (fun session_id () -> - XAPI.get_host_name_label ~session_id ~uuid:host_uuid - ) - () - in - Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; - name_label + match Hashtbl.find_opt host_uuid_to_name_label_map host_uuid with + | Some x -> + x + | None -> + let name_label, _session_id = + XAPI.retry_with_session + (fun session_id () -> + XAPI.get_host_name_label ~session_id ~uuid:host_uuid + ) + () + in + Hashtbl.replace host_uuid_to_name_label_map host_uuid name_label ; + name_label module Ds_selector = struct type t = { diff --git a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml index 21483260f5b..0c8b016cb5c 100644 --- a/ocaml/sdk-gen/csharp/gen_csharp_binding.ml +++ b/ocaml/sdk-gen/csharp/gen_csharp_binding.ml @@ -136,8 +136,8 @@ and gen_relations () = and process_relations ((oneClass, oneField), (manyClass, manyField)) = let value = - try (manyField, oneClass, oneField) :: Hashtbl.find relations manyClass - with Not_found -> [(manyField, oneClass, oneField)] + (manyField, oneClass, oneField) + :: Option.value (Hashtbl.find_opt relations manyClass) ~default:[] in Hashtbl.replace relations manyClass value diff --git a/ocaml/squeezed/lib/squeeze.ml b/ocaml/squeezed/lib/squeeze.ml index 30b203c7e8c..bb308c45639 100644 --- a/ocaml/squeezed/lib/squeeze.ml +++ b/ocaml/squeezed/lib/squeeze.ml @@ -171,16 +171,23 @@ module Stuckness_monitor = struct direction_of_actual domain.inaccuracy_kib domain.memory_actual_kib domain.target_kib in - if not (Hashtbl.mem x.per_domain domain.domid) then - Hashtbl.replace x.per_domain domain.domid - (* new domains are considered to be making progress now and not - stuck *) - { - last_actual_kib= domain.memory_actual_kib - ; last_makingprogress_time= now - ; stuck= false - } ; - let state = Hashtbl.find x.per_domain domain.domid in + let state = + match Hashtbl.find_opt x.per_domain domain.domid with + | Some x -> + x + | None -> + (* new domains are considered to be making + progress now and not stuck *) + let new_data = + { + last_actual_kib= domain.memory_actual_kib + ; last_makingprogress_time= now + ; stuck= false + } + in + Hashtbl.replace x.per_domain domain.domid new_data ; + new_data + in let delta_actual = domain.memory_actual_kib -* state.last_actual_kib in state.last_actual_kib <- domain.memory_actual_kib ; (* If memory_actual is moving towards the target then we say we are @@ -229,10 +236,11 @@ module Stuckness_monitor = struct progress. If it is not making progress it may have either hit its target or it may have failed. *) let domid_is_active (x : t) domid (_ : float) = - if not (Hashtbl.mem x.per_domain domid) then - false (* it must have been destroyed *) - else - not (Hashtbl.find x.per_domain domid).stuck + match Hashtbl.find_opt x.per_domain domid with + | Some x -> + not x.stuck + | None -> + false (* it must have been destroyed *) end type fistpoint = diff --git a/ocaml/squeezed/src/squeeze_xen.ml b/ocaml/squeezed/src/squeeze_xen.ml index f4ba7e5accd..496e7d03ea0 100644 --- a/ocaml/squeezed/src/squeeze_xen.ml +++ b/ocaml/squeezed/src/squeeze_xen.ml @@ -125,9 +125,8 @@ module Domain = struct (* get_per_domain can return None if the domain is deleted by someone else while we are processing some other event handlers *) let get_per_domain xc domid = - if Hashtbl.mem cache domid then - Some (Hashtbl.find cache domid) - else + match Hashtbl.find_opt cache domid with + | None -> ( try let path = Printf.sprintf "/local/domain/%d" domid in let di = Xenctrl.domain_getinfo xc domid in @@ -143,6 +142,9 @@ module Domain = struct Hashtbl.replace cache domid d ; Some d with Xenctrl.Error _ -> Hashtbl.remove cache domid ; None + ) + | x -> + x let remove_gone_domains_cache xc = let current_domains = Xenctrl.domain_getinfolist xc 0 in @@ -385,10 +387,11 @@ module Domain = struct match get_per_domain xc domid with | None -> None - | Some per_domain -> - if Hashtbl.mem per_domain.keys key then - Hashtbl.find per_domain.keys key - else + | Some per_domain -> ( + match Hashtbl.find_opt per_domain.keys key with + | Some x -> + x + | None -> let x = try Some @@ -400,6 +403,7 @@ module Domain = struct in Hashtbl.replace per_domain.keys key x ; x + ) ) in match x with Some y -> y | None -> raise (Xs_protocol.Enoent key) @@ -412,10 +416,8 @@ module Domain = struct | None -> () | Some per_domain -> ( - if - (not (Hashtbl.mem per_domain.keys key)) - || Hashtbl.find per_domain.keys key <> Some value - then + if Option.join (Hashtbl.find_opt per_domain.keys key) <> Some value then + (* Don't update if there is the same value bound already *) try Client.transaction (get_client ()) (fun t -> (* Fail if the directory has been deleted *) diff --git a/ocaml/tapctl/tapctl.ml b/ocaml/tapctl/tapctl.ml index 109e95df3f6..075eea8aba2 100644 --- a/ocaml/tapctl/tapctl.ml +++ b/ocaml/tapctl/tapctl.ml @@ -336,10 +336,12 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "PATH") in + let path_env_var = Option.value (Sys.getenv_opt "PATH") ~default:"" in + let paths = Astring.String.cuts ~sep:":" ~empty:false path_env_var in let xen_paths = - try Astring.String.cuts ~sep:":" ~empty:false (Sys.getenv "XCP_PATH") - with _ -> [] + (* Can't raise an exception since the separator string isn't empty *) + Astring.String.cuts ~sep:":" ~empty:false + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") in let first_hit = List.fold_left @@ -361,7 +363,9 @@ let canonicalise x = let tap_ctl = canonicalise "tap-ctl" let invoke_tap_ctl _ cmd args = - let find x = try [x ^ "=" ^ Sys.getenv x] with _ -> [] in + let find x = + match Sys.getenv_opt x with Some v -> [x ^ "=" ^ v] | None -> [] + in let env = Array.of_list (find "PATH" @ find "TAPDISK" @ find "TAPDISK2") in let stdout, _ = execute_command_get_output ~env tap_ctl (cmd :: args) in stdout diff --git a/ocaml/tests/test_xapi_vbd_helpers.ml b/ocaml/tests/test_xapi_vbd_helpers.ml index 08ea79fda38..0aa4ef0a6d1 100644 --- a/ocaml/tests/test_xapi_vbd_helpers.ml +++ b/ocaml/tests/test_xapi_vbd_helpers.ml @@ -34,11 +34,9 @@ let run_assert_equal_with_vdi ~__context msg ?(expensive_sharing_checks = true) Xapi_vbd_helpers.valid_operations ~__context ~expensive_sharing_checks vbd_record vbd_ref in - match Hashtbl.find valid_ops op with - | Some (code, _) -> - Some code - | None -> - None + Option.map + (fun (code, _) -> code) + (Option.join (Hashtbl.find_opt valid_ops op)) in Alcotest.(check (option string)) msg expected_error_if_any (get_error_code_of op) diff --git a/ocaml/xapi-cli-server/cli_frontend.ml b/ocaml/xapi-cli-server/cli_frontend.ml index b853b27a2ca..1c71177c3c8 100644 --- a/ocaml/xapi-cli-server/cli_frontend.ml +++ b/ocaml/xapi-cli-server/cli_frontend.ml @@ -3887,44 +3887,44 @@ let make_list l = let rio_help printer minimal cmd = let docmd cmd = - try - let cmd_spec = Hashtbl.find cmdtable cmd in - let vm_selectors = List.mem Vm_selectors cmd_spec.flags in - let host_selectors = List.mem Host_selectors cmd_spec.flags in - let sr_selectors = List.mem Sr_selectors cmd_spec.flags in - let optional = - cmd_spec.optn - @ (if vm_selectors then vmselectors else []) - @ (if sr_selectors then srselectors else []) - @ if host_selectors then hostselectors else [] - in - let desc = - match (vm_selectors, host_selectors, sr_selectors) with - | false, false, false -> - cmd_spec.help - | true, false, false -> - cmd_spec.help ^ vmselectorsinfo - | false, true, false -> - cmd_spec.help ^ hostselectorsinfo - | false, false, true -> - cmd_spec.help ^ srselectorsinfo - | _ -> - cmd_spec.help - (* never happens currently *) - in - let recs = - [ - ("command name ", cmd) - ; ("reqd params ", String.concat ", " cmd_spec.reqd) - ; ("optional params ", String.concat ", " optional) - ; ("description ", desc) - ] - in - printer (Cli_printer.PTable [recs]) - with Not_found as e -> - Debug.log_backtrace e (Backtrace.get e) ; - error "Responding with Unknown command %s" cmd ; - printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) + match Hashtbl.find_opt cmdtable cmd with + | Some cmd_spec -> + let vm_selectors = List.mem Vm_selectors cmd_spec.flags in + let host_selectors = List.mem Host_selectors cmd_spec.flags in + let sr_selectors = List.mem Sr_selectors cmd_spec.flags in + let optional = + cmd_spec.optn + @ (if vm_selectors then vmselectors else []) + @ (if sr_selectors then srselectors else []) + @ if host_selectors then hostselectors else [] + in + let desc = + match (vm_selectors, host_selectors, sr_selectors) with + | false, false, false -> + cmd_spec.help + | true, false, false -> + cmd_spec.help ^ vmselectorsinfo + | false, true, false -> + cmd_spec.help ^ hostselectorsinfo + | false, false, true -> + cmd_spec.help ^ srselectorsinfo + | _ -> + cmd_spec.help + (* never happens currently *) + in + let recs = + [ + ("command name ", cmd) + ; ("reqd params ", String.concat ", " cmd_spec.reqd) + ; ("optional params ", String.concat ", " optional) + ; ("description ", desc) + ] + in + printer (Cli_printer.PTable [recs]) + | None -> + D.log_backtrace () ; + error "Responding with Unknown command %s" cmd ; + printer (Cli_printer.PList ["Unknown command '" ^ cmd ^ "'"]) in let cmds = List.filter diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml index f605a435112..83f10a7a46d 100644 --- a/ocaml/xapi-cli-server/cli_operations.ml +++ b/ocaml/xapi-cli-server/cli_operations.ml @@ -650,7 +650,9 @@ let make_param_funs getallrecs getbyuuid record class_name def_filters set_in_map key v | None, Some set_map -> let existing_params = - try Hashtbl.find set_map_table set_map with Not_found -> [] + Option.value + (Hashtbl.find_opt set_map_table set_map) + ~default:[] in Hashtbl.replace set_map_table set_map ((key, v) :: existing_params) | None, None -> diff --git a/ocaml/xapi-cli-server/cli_util.ml b/ocaml/xapi-cli-server/cli_util.ml index 5d7e9ef3e6d..035494a2957 100644 --- a/ocaml/xapi-cli-server/cli_util.ml +++ b/ocaml/xapi-cli-server/cli_util.ml @@ -254,31 +254,30 @@ let ref_convert x = (* Marshal an API-style server-error *) let get_server_error code params = - try - let error = Hashtbl.find Datamodel.errors code in - (* There ought to be a bijection between parameters mentioned in - datamodel.ml and those in the exception but this is unchecked and - false in some cases, defined here. *) - let required = - if code = Api_errors.vms_failed_to_cooperate then - List.map (fun _ -> "VM") params - else - error.Datamodel_types.err_params - in - (* For the rest we attempt to pretty-print the list even when it's short/long *) - let rec pp_params = function - | t :: ts, v :: vs -> - (t ^ ": " ^ v) :: pp_params (ts, vs) - | [], v :: vs -> - (": " ^ v) :: pp_params ([], vs) - | t :: ts, [] -> - (t ^ ": ") :: pp_params (ts, []) - | [], [] -> - [] - in - let errparams = pp_params (required, List.map ref_convert params) in - Some (error.Datamodel_types.err_doc, errparams) - with _ -> None + let ( let* ) = Option.bind in + let* error = Hashtbl.find_opt Datamodel.errors code in + (* There ought to be a bijection between parameters mentioned in + datamodel.ml and those in the exception but this is unchecked and + false in some cases, defined here. *) + let required = + if code = Api_errors.vms_failed_to_cooperate then + List.map (fun _ -> "VM") params + else + error.Datamodel_types.err_params + in + (* For the rest we attempt to pretty-print the list even when it's short/long *) + let rec pp_params = function + | t :: ts, v :: vs -> + (t ^ ": " ^ v) :: pp_params (ts, vs) + | [], v :: vs -> + (": " ^ v) :: pp_params ([], vs) + | t :: ts, [] -> + (t ^ ": ") :: pp_params (ts, []) + | [], [] -> + [] + in + let errparams = pp_params (required, List.map ref_convert params) in + Some (error.Datamodel_types.err_doc, errparams) let server_error (code : string) (params : string list) sock = match get_server_error code params with diff --git a/ocaml/xapi-idl/lib/coverage/enabled.ml b/ocaml/xapi-idl/lib/coverage/enabled.ml index ac128055d75..461221db512 100644 --- a/ocaml/xapi-idl/lib/coverage/enabled.ml +++ b/ocaml/xapi-idl/lib/coverage/enabled.ml @@ -9,7 +9,13 @@ module Bisect = struct let bisect_file = "BISECT_FILE" let dump jobid = - let bisect_prefix = Unix.getenv bisect_file in + let bisect_prefix = + match Sys.getenv_opt bisect_file with + | Some x -> + x + | None -> + D.warn "No $BISECT_FILE default set: %s" __LOC__ + in (* dump coverage information in same location as it would normally get dumped on exit, except also embed the jobid to make it easier to group. Relies on [open_temp_file] generating a unique filename given a @@ -39,8 +45,7 @@ module Bisect = struct let init_env name = let ( // ) = Filename.concat in let tmpdir = Filename.get_temp_dir_name () in - try ignore (Sys.getenv bisect_file) - with Not_found -> + if Option.is_none (Sys.getenv_opt bisect_file) then Unix.putenv bisect_file (tmpdir // Printf.sprintf "bisect-%s-" name) let process body = diff --git a/ocaml/xapi-idl/lib/xcp_service.ml b/ocaml/xapi-idl/lib/xcp_service.ml index 123acd4a249..667e51bd74f 100644 --- a/ocaml/xapi-idl/lib/xcp_service.ml +++ b/ocaml/xapi-idl/lib/xcp_service.ml @@ -364,24 +364,25 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = split_c ':' (Sys.getenv "PATH") in + let paths = + (* Might be worth eliminating split_c function (used in a few + more places in this module and replacing it with + Astring.String.cuts since it's already imported in this module *) + split_c ':' (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let first_hit = - List.fold_left - (fun found path -> - match found with - | Some _hit -> - found - | None -> - let possibility = Filename.concat path x in - if Sys.file_exists possibility then Some possibility else None + List.find_opt + (fun path -> + let possibility = Filename.concat path x in + Sys.file_exists possibility ) - None (paths @ !extra_search_path) in match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or search_path option ( = %s)" - x (Sys.getenv "PATH") + x + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") (String.concat ":" !extra_search_path) ; x | Some hit -> diff --git a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml index fe7b15258aa..298099be057 100644 --- a/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml +++ b/ocaml/xapi-storage-script/examples/volume/org.xen.xcp.storage.plainlvm/common.ml @@ -126,9 +126,13 @@ let canonicalise x = if not (Filename.is_relative x) then x else (* Search the PATH and XCP_PATH for the executable *) - let paths = Re_str.split colon (Sys.getenv "PATH") in + let paths = + Re_str.split colon (Option.value (Sys.getenv_opt "PATH") ~default:"") + in let xen_paths = - try Re_str.split colon (Sys.getenv "XCP_PATH") with _ -> [] + try + Re_str.split colon (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"") + with _ -> [] in let first_hit = List.fold_left @@ -148,8 +152,8 @@ let canonicalise x = match first_hit with | None -> warn "Failed to find %s on $PATH ( = %s) or $XCP_PATH ( = %s)" x - (Sys.getenv "PATH") - (try Sys.getenv "XCP_PATH" with Not_found -> "unset") ; + (Option.value (Sys.getenv_opt "PATH") ~default:"unset") + (Option.value (Sys.getenv_opt "XCP_PATH") ~default:"unset") ; x | Some hit -> hit diff --git a/ocaml/xapi-storage-script/main.ml b/ocaml/xapi-storage-script/main.ml index fbfc4796220..8b5673701ba 100644 --- a/ocaml/xapi-storage-script/main.ml +++ b/ocaml/xapi-storage-script/main.ml @@ -1644,13 +1644,13 @@ let watch_volume_plugins ~volume_root ~switch_path ~pipe = in let destroy volume_plugin_name = info "Removing %s" volume_plugin_name ; - if Hashtbl.mem servers volume_plugin_name then ( - let t = Hashtbl.find_exn servers volume_plugin_name in - Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> - Hashtbl.remove servers volume_plugin_name ; - return () - ) else - return () + match Hashtbl.find servers volume_plugin_name with + | Some t -> + Message_switch_async.Protocol_async.Server.shutdown ~t () >>= fun () -> + Hashtbl.remove servers volume_plugin_name ; + return () + | None -> + return () in let sync () = Sys.readdir volume_root >>= fun names -> diff --git a/ocaml/xapi/binpack.ml b/ocaml/xapi/binpack.ml index cef4730b1cb..e89a775c749 100644 --- a/ocaml/xapi/binpack.ml +++ b/ocaml/xapi/binpack.ml @@ -51,11 +51,13 @@ let biggest_fit_decreasing (things : ('a * int64) list) let memoise f = let table = Hashtbl.create 10 in let rec lookup x = - if Hashtbl.mem table x then - Hashtbl.find table x - else - let result = f lookup x in - Hashtbl.add table x result ; result + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + let result = f lookup x in + Hashtbl.replace table x result ; + result in lookup diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index c7fb5d93373..a0442314448 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -91,12 +91,11 @@ let check_host_liveness ~__context = let live = Db.Host_metrics.get_live ~__context ~self:hmetric in (* See if the host is using the new HB mechanism, if so we'll use that *) let new_heartbeat_time = - try - with_lock host_table_m (fun () -> - Hashtbl.find host_heartbeat_table host - ) - with _ -> 0.0 - (* never *) + with_lock host_table_m (fun () -> + Option.value + (Hashtbl.find_opt host_heartbeat_table host) + ~default:Clock.Date.(epoch |> to_unix_time) + ) in let old_heartbeat_time = if @@ -141,11 +140,9 @@ let check_host_liveness ~__context = ) ; (* Check for clock skew *) detect_clock_skew ~__context host - ( try - with_lock host_table_m (fun () -> - Hashtbl.find host_skew_table host - ) - with _ -> 0. + (with_lock host_table_m (fun () -> + Option.value (Hashtbl.find_opt host_skew_table host) ~default:0. + ) ) with exn -> debug "Ignoring exception inspecting metrics of host %s: %s" diff --git a/ocaml/xapi/db_gc_util.ml b/ocaml/xapi/db_gc_util.ml index eb86d981291..182eaac00df 100644 --- a/ocaml/xapi/db_gc_util.ml +++ b/ocaml/xapi/db_gc_util.ml @@ -322,12 +322,13 @@ let timeout_tasks ~__context = let pending_old_run, pending_old_hung = List.partition (fun (_, t) -> - try - let pre_progress = - Hashtbl.find probation_pending_tasks t.Db_actions.task_uuid - in - t.Db_actions.task_progress -. pre_progress > min_float - with Not_found -> true + match + Hashtbl.find_opt probation_pending_tasks t.Db_actions.task_uuid + with + | Some pre_progress -> + t.Db_actions.task_progress -. pre_progress > min_float + | None -> + true ) pending_old in @@ -505,7 +506,7 @@ let timeout_sessions ~__context = `Name s.Db_actions.session_auth_user_name in let current_sessions = - try Hashtbl.find session_groups key with Not_found -> [] + Option.value (Hashtbl.find_opt session_groups key) ~default:[] in Hashtbl.replace session_groups key (rs :: current_sessions) ) diff --git a/ocaml/xapi/eventgen.ml b/ocaml/xapi/eventgen.ml index 274e74abb78..f03db1e9bed 100644 --- a/ocaml/xapi/eventgen.ml +++ b/ocaml/xapi/eventgen.ml @@ -22,10 +22,9 @@ let get_record_table : Hashtbl.create 20 let find_get_record x ~__context ~self () : Rpc.t option = - if Hashtbl.mem get_record_table x then - Some (Hashtbl.find get_record_table x ~__context ~self ()) - else - None + Option.map + (fun x -> x ~__context ~self ()) + (Hashtbl.find_opt get_record_table x) (* If a record is created or destroyed, then for any (Ref _) field which is one end of a relationship, need to send diff --git a/ocaml/xapi/export.ml b/ocaml/xapi/export.ml index 326efdaf067..6cb156d21ca 100644 --- a/ocaml/xapi/export.ml +++ b/ocaml/xapi/export.ml @@ -157,10 +157,11 @@ let create_table () = Hashtbl.create 10 (** Convert an internal reference into an external one or NULL *) let lookup table r = - if not (Hashtbl.mem table r) then - Ref.null - else - Ref.of_string (Hashtbl.find table r) + match Hashtbl.find_opt table r with + | Some x -> + Ref.of_string x + | None -> + Ref.null (** Convert a list of internal references into external references, filtering out NULLs *) let filter table rs = diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index d8992fef80d..6c0a5d59075 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -85,7 +85,11 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args = Unix.access script [Unix.X_OK] ; (* Use the same $PATH as xapi *) let env = - match env with None -> [|"PATH=" ^ Sys.getenv "PATH"|] | Some env -> env + match env with + | None -> + [|"PATH=" ^ Option.value (Sys.getenv_opt "PATH") ~default:""|] + | Some env -> + env in let output, _ = match stdin with @@ -1568,9 +1572,12 @@ module Early_wakeup = struct let signal key = (*debug "Early_wakeup signal key = (%s, %s)" a b;*) with_lock table_m (fun () -> - if Hashtbl.mem table key then - (*debug "Signalling thread blocked on (%s,%s)" a b;*) - Delay.signal (Hashtbl.find table key) + Option.iter + (fun x -> + (*debug "Signalling thread blocked on (%s,%s)" a b;*) + Delay.signal x + ) + (Hashtbl.find_opt table key) ) end diff --git a/ocaml/xapi/localdb.ml b/ocaml/xapi/localdb.ml index 0cfa222138c..3382c42e32a 100644 --- a/ocaml/xapi/localdb.ml +++ b/ocaml/xapi/localdb.ml @@ -66,7 +66,11 @@ let m = Mutex.create () let get (key : string) = with_lock m (fun () -> assert_loaded () ; - try Hashtbl.find db key with Not_found -> raise (Missing_key key) + match Hashtbl.find_opt db key with + | Some x -> + x + | None -> + raise (Missing_key key) ) let get_with_default (key : string) (default : string) = @@ -74,11 +78,11 @@ let get_with_default (key : string) (default : string) = (* Returns true if a change was made and should be flushed *) let put_one (key : string) (v : string) = - if Hashtbl.mem db key && Hashtbl.find db key = v then - false (* no change necessary *) - else ( - Hashtbl.replace db key v ; true - ) + match Hashtbl.find_opt db key with + | Some x when x = v -> + false (* no change necessary *) + | _ -> + Hashtbl.replace db key v ; true let flush () = let b = Buffer.create 256 in diff --git a/ocaml/xapi/monitor_dbcalls_cache.ml b/ocaml/xapi/monitor_dbcalls_cache.ml index 507500b20dc..a0aad3d1766 100644 --- a/ocaml/xapi/monitor_dbcalls_cache.ml +++ b/ocaml/xapi/monitor_dbcalls_cache.ml @@ -96,8 +96,11 @@ let clear_cache () = let transfer_map ?(except = []) ~source ~target () = List.iter (fun ex -> - try Hashtbl.replace source ex (Hashtbl.find target ex) - with Not_found -> Hashtbl.remove source ex + match Hashtbl.find_opt target ex with + | Some elem -> + Hashtbl.replace source ex elem + | None -> + Hashtbl.remove source ex ) except ; Hashtbl.clear target ; @@ -107,10 +110,11 @@ let transfer_map ?(except = []) ~source ~target () = let get_updates ~before ~after ~f = Hashtbl.fold (fun k v acc -> - if try v <> Hashtbl.find before k with Not_found -> true then - f k v acc - else - acc + match Hashtbl.find_opt before k with + | Some x when v = x -> + acc + | _ -> + f k v acc ) after [] diff --git a/ocaml/xapi/rbac.ml b/ocaml/xapi/rbac.ml index c304b5a991d..5b442f11a4a 100644 --- a/ocaml/xapi/rbac.ml +++ b/ocaml/xapi/rbac.ml @@ -149,10 +149,12 @@ let is_permission_in_session ~session_id ~permission ~session = let find_linear elem set = List.exists (fun e -> e = elem) set in let find_log elem set = Permission_set.mem elem set in let permission_tree = - try Some (Hashtbl.find session_permissions_tbl session_id) - with Not_found -> - create_session_permissions_tbl ~session_id - ~rbac_permissions:session.API.session_rbac_permissions + match Hashtbl.find_opt session_permissions_tbl session_id with + | None -> + create_session_permissions_tbl ~session_id + ~rbac_permissions:session.API.session_rbac_permissions + | x -> + x in match permission_tree with | Some permission_tree -> diff --git a/ocaml/xapi/slave_backup.ml b/ocaml/xapi/slave_backup.ml index aeb3e3e1e95..6a8a41c8a90 100644 --- a/ocaml/xapi/slave_backup.ml +++ b/ocaml/xapi/slave_backup.ml @@ -34,13 +34,15 @@ let with_backup_lock f = Xapi_stdext_threads.Threadext.Mutex.execute backup_m f log it in table and return that *) (* IMPORTANT: must be holding backup_m mutex when you call this function.. *) let lookup_write_entry dbconn = - try Hashtbl.find backup_write_table dbconn - with _ -> - let new_write_entry = - {period_start_time= Unix.gettimeofday (); writes_this_period= 0} - in - Hashtbl.replace backup_write_table dbconn new_write_entry ; - new_write_entry + match Hashtbl.find_opt backup_write_table dbconn with + | Some x -> + x + | None -> + let new_write_entry = + {period_start_time= Unix.gettimeofday (); writes_this_period= 0} + in + Hashtbl.replace backup_write_table dbconn new_write_entry ; + new_write_entry (* Reset period_start_time, writes_this_period if period has expired *) let tick_backup_write_table () = diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml index df438a656bd..40e9b11e3e2 100644 --- a/ocaml/xapi/sm.ml +++ b/ocaml/xapi/sm.ml @@ -50,10 +50,11 @@ let register ~__context () = let info_of_driver (name : string) = let name = String.lowercase_ascii name in - if not (Hashtbl.mem driver_info_cache name) then - raise (Unknown_driver name) - else - Hashtbl.find driver_info_cache name + match Hashtbl.find_opt driver_info_cache name with + | Some x -> + x + | None -> + raise (Unknown_driver name) let features_of_driver (name : string) = (info_of_driver name).sr_driver_features diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index 292c96b4f52..02e5545d16e 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -409,7 +409,7 @@ let remove_from_progress_map id = let get_progress_map id = with_lock progress_map_m (fun () -> - try Hashtbl.find progress_map_tbl id with _ -> fun x -> x + Option.value (Hashtbl.find_opt progress_map_tbl id) ~default:Fun.id ) let register_mirror __context mid = diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index eff980cfbe6..468cddb2bf0 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -258,7 +258,7 @@ module State = struct let find id table = access_table ~save_after:false - (fun table -> try Some (Hashtbl.find table id) with Not_found -> None) + (fun table -> Hashtbl.find_opt table id) table let remove id table = diff --git a/ocaml/xapi/storage_mux.ml b/ocaml/xapi/storage_mux.ml index 0dcef1d201f..3a11ad0077f 100644 --- a/ocaml/xapi/storage_mux.ml +++ b/ocaml/xapi/storage_mux.ml @@ -77,29 +77,35 @@ let unregister sr = ) ) +(* This function is entirely unused, but I am not sure if it should be + deleted or not *) let query_result_of_sr sr = - try with_lock m (fun () -> Some (Hashtbl.find plugins sr).query_result) - with _ -> None + with_lock m (fun () -> + Option.map (fun x -> x.query_result) (Hashtbl.find_opt plugins sr) + ) let sr_has_capability sr capability = - try - with_lock m (fun () -> - Smint.has_capability capability (Hashtbl.find plugins sr).features - ) - with _ -> false + with_lock m (fun () -> + match Hashtbl.find_opt plugins sr with + | Some x -> + Smint.has_capability capability x.features + | None -> + false + ) (* This is the policy: *) let of_sr sr = with_lock m (fun () -> - if not (Hashtbl.mem plugins sr) then ( - error "No storage plugin for SR: %s (currently-registered = [ %s ])" - (s_of_sr sr) - (String.concat ", " - (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) - ) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).processor + match Hashtbl.find_opt plugins sr with + | Some x -> + x.processor + | None -> + error "No storage plugin for SR: %s (currently-registered = [ %s ])" + (s_of_sr sr) + (String.concat ", " + (Hashtbl.fold (fun sr _ acc -> s_of_sr sr :: acc) plugins []) + ) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) ) type 'a sm_result = SMSuccess of 'a | SMFailure of exn @@ -848,11 +854,12 @@ module Mux = struct module Policy = struct let get_backend_vm () ~dbg:_ ~vm:_ ~sr ~vdi:_ = - if not (Hashtbl.mem plugins sr) then ( - error "No registered plugin for sr = %s" (s_of_sr sr) ; - raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) - ) else - (Hashtbl.find plugins sr).backend_domain + match Hashtbl.find_opt plugins sr with + | Some x -> + x.backend_domain + | None -> + error "No registered plugin for sr = %s" (s_of_sr sr) ; + raise (Storage_error (No_storage_plugin_for_sr (s_of_sr sr))) end module TASK = Storage_smapiv1_wrapper.Impl.TASK diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml index b6abfdcd2c3..465b5d354b1 100644 --- a/ocaml/xapi/storage_smapiv1.ml +++ b/ocaml/xapi/storage_smapiv1.ml @@ -590,10 +590,13 @@ module SMAPIv1 : Server_impl = struct try let read_write = with_lock vdi_read_write_m (fun () -> - if not (Hashtbl.mem vdi_read_write (sr, vdi)) then - error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" - (s_of_sr sr) (s_of_vdi vdi) ; - Hashtbl.find vdi_read_write (sr, vdi) + match Hashtbl.find_opt vdi_read_write (sr, vdi) with + | Some x -> + x + | None -> + error "VDI.activate: doesn't know if sr:%s vdi:%s is RO or RW" + (s_of_sr sr) (s_of_vdi vdi) ; + false ) in for_vdi ~dbg ~sr ~vdi "VDI.activate" (fun device_config _type sr self -> diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml index 8fde6ec60bd..04d0e99ecf8 100644 --- a/ocaml/xapi/storage_smapiv1_wrapper.ml +++ b/ocaml/xapi/storage_smapiv1_wrapper.ml @@ -250,10 +250,7 @@ module Sr = struct let m = Mutex.create () - let find vdi sr = - with_lock m (fun () -> - try Some (Hashtbl.find sr.vdis vdi) with Not_found -> None - ) + let find vdi sr = with_lock m (fun () -> Hashtbl.find_opt sr.vdis vdi) let add_or_replace vdi vdi_t sr = with_lock m (fun () -> Hashtbl.replace sr.vdis vdi vdi_t) @@ -289,10 +286,7 @@ module Host = struct let m = Mutex.create () - let find sr h = - with_lock m (fun () -> - try Some (Hashtbl.find h.srs sr) with Not_found -> None - ) + let find sr h = with_lock m (fun () -> Hashtbl.find_opt h.srs sr) let remove sr h = with_lock m (fun () -> Hashtbl.remove h.srs sr) @@ -388,12 +382,13 @@ functor let locks_find sr = let sr_key = s_of_sr sr in with_lock locks_m (fun () -> - if not (Hashtbl.mem locks sr_key) then ( - let result = Storage_locks.make () in - Hashtbl.replace locks sr_key result ; - result - ) else - Hashtbl.find locks sr_key + match Hashtbl.find_opt locks sr_key with + | Some x -> + x + | None -> + let result = Storage_locks.make () in + Hashtbl.replace locks sr_key result ; + result ) let locks_remove sr = diff --git a/ocaml/xapi/system_domains.ml b/ocaml/xapi/system_domains.ml index 2b2b5095c90..5fb394605b1 100644 --- a/ocaml/xapi/system_domains.ml +++ b/ocaml/xapi/system_domains.ml @@ -258,7 +258,7 @@ let unregister_service service = let get_service service = with_lock service_to_queue_m (fun () -> - try Some (Hashtbl.find service_to_queue service) with Not_found -> None + Hashtbl.find_opt service_to_queue service ) let list_services () = diff --git a/ocaml/xapi/xapi_dr.ml b/ocaml/xapi/xapi_dr.ml index b2f80481324..dfe563ec204 100644 --- a/ocaml/xapi/xapi_dr.ml +++ b/ocaml/xapi/xapi_dr.ml @@ -150,12 +150,7 @@ let remove_vdis_from_cache ~__context ~vdis = ) let read_vdi_cache_record ~vdi = - with_lock db_vdi_cache_mutex (fun () -> - if Hashtbl.mem db_vdi_cache vdi then - Some (Hashtbl.find db_vdi_cache vdi) - else - None - ) + with_lock db_vdi_cache_mutex (fun () -> Hashtbl.find_opt db_vdi_cache vdi) let handle_metadata_vdis ~__context ~sr = let sr_uuid = Db.SR.get_uuid ~__context ~self:sr in diff --git a/ocaml/xapi/xapi_event.ml b/ocaml/xapi/xapi_event.ml index 4c6a5eac959..b56e4199779 100644 --- a/ocaml/xapi/xapi_event.ml +++ b/ocaml/xapi/xapi_event.ml @@ -224,21 +224,22 @@ module Next = struct one if one doesn't exist already *) let get_subscription session = with_lock m (fun () -> - if Hashtbl.mem subscriptions session then - Hashtbl.find subscriptions session - else - let subscription = - { - last_id= !id - ; subs= [] - ; m= Mutex.create () - ; session - ; session_invalid= false - ; timeout= 0.0 - } - in - Hashtbl.replace subscriptions session subscription ; - subscription + match Hashtbl.find_opt subscriptions session with + | Some x -> + x + | None -> + let subscription = + { + last_id= !id + ; subs= [] + ; m= Mutex.create () + ; session + ; session_invalid= false + ; timeout= 0.0 + } + in + Hashtbl.replace subscriptions session subscription ; + subscription ) let on_session_deleted session_id = @@ -248,11 +249,12 @@ module Next = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem subscriptions session_id then ( - let sub = Hashtbl.find subscriptions session_id in - mark_invalid sub ; - Hashtbl.remove subscriptions session_id - ) + Option.iter + (fun sub -> + mark_invalid sub ; + Hashtbl.remove subscriptions session_id + ) + (Hashtbl.find_opt subscriptions session_id) ) let session_is_invalid sub = with_lock sub.m (fun () -> sub.session_invalid) @@ -381,10 +383,7 @@ module From = struct in with_lock m (fun () -> let existing = - if Hashtbl.mem calls session then - Hashtbl.find calls session - else - [] + Option.value (Hashtbl.find_opt calls session) ~default:[] in Hashtbl.replace calls session (fresh :: existing) ) ; @@ -392,15 +391,17 @@ module From = struct (fun () -> f fresh) (fun () -> with_lock m (fun () -> - if Hashtbl.mem calls session then - let existing = Hashtbl.find calls session in - let remaining = - List.filter (fun x -> not (x.index = fresh.index)) existing - in - if remaining = [] then - Hashtbl.remove calls session - else - Hashtbl.replace calls session remaining + Option.iter + (fun existing -> + let remaining = + List.filter (fun x -> not (x.index = fresh.index)) existing + in + if remaining = [] then + Hashtbl.remove calls session + else + Hashtbl.replace calls session remaining + ) + (Hashtbl.find_opt calls session) ) ) @@ -412,10 +413,12 @@ module From = struct with_lock sub.m (fun () -> sub.session_invalid <- true) ; Condition.broadcast c in - if Hashtbl.mem calls session_id then ( - List.iter mark_invalid (Hashtbl.find calls session_id) ; - Hashtbl.remove calls session_id - ) + Option.iter + (fun x -> + List.iter mark_invalid x ; + Hashtbl.remove calls session_id + ) + (Hashtbl.find_opt calls session_id) ) let session_is_invalid call = with_lock call.m (fun () -> call.session_invalid) diff --git a/ocaml/xapi/xapi_guest_agent.ml b/ocaml/xapi/xapi_guest_agent.ml index 1de7d904748..ffe5b8ae618 100644 --- a/ocaml/xapi/xapi_guest_agent.ml +++ b/ocaml/xapi/xapi_guest_agent.ml @@ -354,30 +354,32 @@ let all (lookup : string -> string option) (list : string -> string list) let self = Db.VM.get_by_uuid ~__context ~uuid in let guest_metrics_cached = with_lock mutex (fun () -> - try Hashtbl.find cache domid - with _ -> - (* Make sure our cached idea of whether the domain is live or not is correct *) - let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in - let live = - true - && Db.is_valid_ref __context vm_guest_metrics - && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics - in - if live then - dead_domains := IntSet.remove domid !dead_domains - else - dead_domains := IntSet.add domid !dead_domains ; - { - pv_drivers_version= [] - ; os_version= [] - ; networks= [] - ; other= [] - ; memory= [] - ; device_id= [] - ; last_updated= 0.0 - ; can_use_hotplug_vbd= `unspecified - ; can_use_hotplug_vif= `unspecified - } + match Hashtbl.find_opt cache domid with + | Some x -> + x + | None -> + (* Make sure our cached idea of whether the domain is live or not is correct *) + let vm_guest_metrics = Db.VM.get_guest_metrics ~__context ~self in + let live = + true + && Db.is_valid_ref __context vm_guest_metrics + && Db.VM_guest_metrics.get_live ~__context ~self:vm_guest_metrics + in + if live then + dead_domains := IntSet.remove domid !dead_domains + else + dead_domains := IntSet.add domid !dead_domains ; + { + pv_drivers_version= [] + ; os_version= [] + ; networks= [] + ; other= [] + ; memory= [] + ; device_id= [] + ; last_updated= 0.0 + ; can_use_hotplug_vbd= `unspecified + ; can_use_hotplug_vif= `unspecified + } ) in (* Only if the data is valid, cache it (CA-20353) *) diff --git a/ocaml/xapi/xapi_ha_vm_failover.ml b/ocaml/xapi/xapi_ha_vm_failover.ml index 4aa9ee17128..c834e384251 100644 --- a/ocaml/xapi/xapi_ha_vm_failover.ml +++ b/ocaml/xapi/xapi_ha_vm_failover.ml @@ -1423,10 +1423,11 @@ let restart_auto_run_vms ~__context live_set n = ) ; (* If we tried before and failed, don't retry again within 2 minutes *) let attempt_restart = - if Hashtbl.mem last_start_attempt vm then - Unix.gettimeofday () -. Hashtbl.find last_start_attempt vm > 120. - else - true + match Hashtbl.find_opt last_start_attempt vm with + | Some x -> + Unix.gettimeofday () -. x > 120. + | None -> + true in if attempt_restart then ( Hashtbl.replace last_start_attempt vm (Unix.gettimeofday ()) ; diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index 389e8a4d578..666c5500bf4 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -123,7 +123,7 @@ let bugreport_upload ~__context ~host:_ ~url ~options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let cmd = Printf.sprintf "%s %s %s" diff --git a/ocaml/xapi/xapi_host_helpers.ml b/ocaml/xapi/xapi_host_helpers.ml index dcac8edc5ce..beb3f2d13b0 100644 --- a/ocaml/xapi/xapi_host_helpers.ml +++ b/ocaml/xapi/xapi_host_helpers.ml @@ -152,21 +152,22 @@ let valid_operations ~__context record _ref' = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_host_helpers.assert_operation_valid unknown operation: %s" - (host_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_host_helpers.assert_operation_valid unknown operation: \ + %s" + (host_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.host_allowed_operations) diff --git a/ocaml/xapi/xapi_pci_helpers.ml b/ocaml/xapi/xapi_pci_helpers.ml index 873031c9f35..4e7009e2bdb 100644 --- a/ocaml/xapi/xapi_pci_helpers.ml +++ b/ocaml/xapi/xapi_pci_helpers.ml @@ -75,10 +75,12 @@ end = struct let make () = Hashtbl.create 100 let is_virtual t addr = - try Hashtbl.find t addr - with Not_found -> - let v = is_virtual addr in - Hashtbl.replace t addr v ; v + match Hashtbl.find_opt t addr with + | Some x -> + x + | None -> + let v = is_virtual addr in + Hashtbl.replace t addr v ; v end (** [is_related_to x y] is true, if two non-virtual PCI devices diff --git a/ocaml/xapi/xapi_pool_helpers.ml b/ocaml/xapi/xapi_pool_helpers.ml index d8c31f7071a..d023cce84d1 100644 --- a/ocaml/xapi/xapi_pool_helpers.ml +++ b/ocaml/xapi/xapi_pool_helpers.ml @@ -128,21 +128,22 @@ let valid_operations ~__context record (pool : API.ref_pool) = table let throw_error table op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_pool_helpers.assert_operation_valid unknown operation: %s" - (pool_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_pool_helpers.assert_operation_valid unknown operation: \ + %s" + (pool_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.pool_allowed_operations) diff --git a/ocaml/xapi/xapi_pool_update.ml b/ocaml/xapi/xapi_pool_update.ml index a7ec305a9a6..daed914ccdf 100644 --- a/ocaml/xapi/xapi_pool_update.ml +++ b/ocaml/xapi/xapi_pool_update.ml @@ -125,7 +125,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> assert_update_vbds_attached ~__context ~vdi ; let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.detach_helper '%s' count=%d" uuid count ; if count <= 1 then @@ -139,7 +141,9 @@ let with_dec_refcount ~__context ~uuid ~vdi f = let with_inc_refcount ~__context ~uuid ~vdi f = with_lock updates_to_attach_count_tbl_mutex (fun () -> let count = - try Hashtbl.find updates_to_attach_count_tbl uuid with _ -> 0 + Option.value + (Hashtbl.find_opt updates_to_attach_count_tbl uuid) + ~default:0 in debug "pool_update.attach_helper refcount='%d'" count ; if count = 0 then diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index 6e562023ceb..a7eaf1112da 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -47,12 +47,12 @@ let _ = (fun r -> Hashtbl.add static_role_by_name_label_tbl r.role_name_label r) get_all_static_roles -let find_role_by_ref ref = Hashtbl.find static_role_by_ref_tbl ref +let find_role_by_ref ref = Hashtbl.find_opt static_role_by_ref_tbl ref -let find_role_by_uuid uuid = Hashtbl.find static_role_by_uuid_tbl uuid +let find_role_by_uuid uuid = Hashtbl.find_opt static_role_by_uuid_tbl uuid let find_role_by_name_label name_label = - Hashtbl.find static_role_by_name_label_tbl name_label + Hashtbl.find_opt static_role_by_name_label_tbl name_label (* val get_all : __context:Context.t -> ref_role_set*) let get_all ~__context = @@ -64,13 +64,13 @@ let get_all ~__context = let is_valid_role ~__context ~role = Hashtbl.mem static_role_by_ref_tbl role let get_common ~__context ~self ~static_fn ~db_fn = - try - (* first look up across the static roles *) - let static_record = find_role_by_ref self in - static_fn static_record - with Not_found -> - (* then look up across the roles in the Db *) - db_fn ~__context ~self + match find_role_by_ref self with + (* first look up across the static roles *) + | Some static_record -> + static_fn static_record + | None -> + (* then look up across the roles in the Db *) + db_fn ~__context ~self (* val get_record : __context:Context.t -> self:ref_role -> role_t*) let get_api_record ~static_record = @@ -121,20 +121,20 @@ let get_all_records ~__context = get_all_records_where ~__context ~expr:"True" (* val get_by_uuid : __context:Context.t -> uuid:string -> ref_role*) let get_by_uuid ~__context ~uuid = - try - let static_record = find_role_by_uuid uuid in - ref_of_role ~role:static_record - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_uuid ~__context ~uuid + match find_role_by_uuid uuid with + | Some static_record -> + ref_of_role ~role:static_record + | None -> + (* pass-through to Db *) + Db.Role.get_by_uuid ~__context ~uuid let get_by_name_label ~__context ~label = - try - let static_record = find_role_by_name_label label in - [ref_of_role ~role:static_record] - with Not_found -> - (* pass-through to Db *) - Db.Role.get_by_name_label ~__context ~label + match find_role_by_name_label label with + | Some static_record -> + [ref_of_role ~role:static_record] + | None -> + (* pass-through to Db *) + Db.Role.get_by_name_label ~__context ~label (* val get_uuid : __context:Context.t -> self:ref_role -> string*) let get_uuid ~__context ~self = diff --git a/ocaml/xapi/xapi_sr_operations.ml b/ocaml/xapi/xapi_sr_operations.ml index 55c0d6805c6..56f4c466ce6 100644 --- a/ocaml/xapi/xapi_sr_operations.ml +++ b/ocaml/xapi/xapi_sr_operations.ml @@ -98,6 +98,9 @@ let valid_operations ~__context ?op record _ref' : table = (ops : API.storage_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops (disallowed_during_rpu) *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -221,21 +224,21 @@ let valid_operations ~__context ?op record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_sr.assert_operation_valid unknown operation: %s" - (sr_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_sr.assert_operation_valid unknown operation: %s" + (sr_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.storage_operations) = diff --git a/ocaml/xapi/xapi_support.ml b/ocaml/xapi/xapi_support.ml index 7d073b33020..5e65d586776 100644 --- a/ocaml/xapi/xapi_support.ml +++ b/ocaml/xapi/xapi_support.ml @@ -29,7 +29,7 @@ let do_upload label file url options = if List.mem_assoc "http_proxy" options then List.assoc "http_proxy" options else - try Unix.getenv "http_proxy" with _ -> "" + Option.value (Sys.getenv_opt "http_proxy") ~default:"" in let env = Helpers.env_with_path [("URL", url); ("PROXY", proxy)] in match diff --git a/ocaml/xapi/xapi_vbd_helpers.ml b/ocaml/xapi/xapi_vbd_helpers.ml index a24a9fb5106..6226b26c34e 100644 --- a/ocaml/xapi/xapi_vbd_helpers.ml +++ b/ocaml/xapi/xapi_vbd_helpers.ml @@ -60,6 +60,9 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = (ops : API.vbd_operations_set) = List.iter (fun op -> + (* Exception can't be raised since the hash table is + pre-filled for all_ops, and set_errors is applied + to a subset of all_ops *) if Hashtbl.find table op = None then Hashtbl.replace table op (Some (code, params)) ) @@ -296,21 +299,21 @@ let valid_operations ~expensive_sharing_checks ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" - (vbd_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vbd_helpers.assert_operation_valid unknown operation: %s" + (vbd_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vbd_operations) = diff --git a/ocaml/xapi/xapi_vdi_helpers.ml b/ocaml/xapi/xapi_vdi_helpers.ml index 0fe39c68c26..15b00211d73 100644 --- a/ocaml/xapi/xapi_vdi_helpers.ml +++ b/ocaml/xapi/xapi_vdi_helpers.ml @@ -151,25 +151,25 @@ let disable_database_replication ~__context ~vdi = debug "Attempting to disable metadata replication on VDI [%s:%s]." (Db.VDI.get_name_label ~__context ~self:vdi) (Db.VDI.get_uuid ~__context ~self:vdi) ; - if not (Hashtbl.mem metadata_replication vdi) then - debug "Metadata is not being replicated to this VDI." - else - let vbd, log = Hashtbl.find metadata_replication vdi in - Redo_log.shutdown log ; - Redo_log.disable log ; - (* Check the recorded VBD still exists before trying to unplug and destroy it. *) - if Db.is_valid_ref __context vbd then - Helpers.call_api_functions ~__context (fun rpc session_id -> - try - Attach_helpers.safe_unplug rpc session_id vbd ; - Client.VBD.destroy ~rpc ~session_id ~self:vbd - with e -> - debug "Caught %s while trying to dispose of VBD %s." - (Printexc.to_string e) (Ref.string_of vbd) - ) ; - Hashtbl.remove metadata_replication vdi ; - Redo_log.delete log ; - Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false + match Hashtbl.find_opt metadata_replication vdi with + | None -> + debug "Metadata is not being replicated to this VDI." + | Some (vbd, log) -> + Redo_log.shutdown log ; + Redo_log.disable log ; + (* Check the recorded VBD still exists before trying to unplug and destroy it. *) + if Db.is_valid_ref __context vbd then + Helpers.call_api_functions ~__context (fun rpc session_id -> + try + Attach_helpers.safe_unplug rpc session_id vbd ; + Client.VBD.destroy ~rpc ~session_id ~self:vbd + with e -> + debug "Caught %s while trying to dispose of VBD %s." + (Printexc.to_string e) (Ref.string_of vbd) + ) ; + Hashtbl.remove metadata_replication vdi ; + Redo_log.delete log ; + Db.VDI.set_metadata_latest ~__context ~self:vdi ~value:false ) let database_open_mutex = Mutex.create () diff --git a/ocaml/xapi/xapi_vif_helpers.ml b/ocaml/xapi/xapi_vif_helpers.ml index 751f987a6da..5b1f1f458f5 100644 --- a/ocaml/xapi/xapi_vif_helpers.ml +++ b/ocaml/xapi/xapi_vif_helpers.ml @@ -155,21 +155,21 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vif_helpers.assert_operation_valid unknown operation: %s" - (vif_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vif_helpers.assert_operation_valid unknown operation: %s" + (vif_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let assert_operation_valid ~__context ~self ~(op : API.vif_operations) = diff --git a/ocaml/xapi/xapi_vm.ml b/ocaml/xapi/xapi_vm.ml index 8a03aba27e1..8819d393170 100644 --- a/ocaml/xapi/xapi_vm.ml +++ b/ocaml/xapi/xapi_vm.ml @@ -1117,11 +1117,11 @@ let record_call_plugin_latest vm = List.iter (Hashtbl.remove call_plugin_latest) !to_gc ; (* Then calculate the schedule *) let to_wait = - if Hashtbl.mem call_plugin_latest vm then - let t = Hashtbl.find call_plugin_latest vm in - Int64.sub (Int64.add t interval) now - else - 0L + match Hashtbl.find_opt call_plugin_latest vm with + | Some t -> + Int64.sub (Int64.add t interval) now + | None -> + 0L in if to_wait > 0L then raise diff --git a/ocaml/xapi/xapi_vusb_helpers.ml b/ocaml/xapi/xapi_vusb_helpers.ml index 09de9f80731..4c8b8d5eb2a 100644 --- a/ocaml/xapi/xapi_vusb_helpers.ml +++ b/ocaml/xapi/xapi_vusb_helpers.ml @@ -92,21 +92,22 @@ let valid_operations ~__context record _ref' : table = table let throw_error (table : table) op = - if not (Hashtbl.mem table op) then - raise - (Api_errors.Server_error - ( Api_errors.internal_error - , [ - Printf.sprintf - "xapi_vusb_helpers.assert_operation_valid unknown operation: %s" - (vusb_operation_to_string op) - ] - ) - ) ; - match Hashtbl.find table op with - | Some (code, params) -> - raise (Api_errors.Server_error (code, params)) + match Hashtbl.find_opt table op with | None -> + raise + (Api_errors.Server_error + ( Api_errors.internal_error + , [ + Printf.sprintf + "xapi_vusb_helpers.assert_operation_valid unknown operation: \ + %s" + (vusb_operation_to_string op) + ] + ) + ) + | Some (Some (code, params)) -> + raise (Api_errors.Server_error (code, params)) + | Some None -> () let update_allowed_operations ~__context ~self : unit = diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml index f756dac6fe0..50aa2c6c53d 100644 --- a/ocaml/xapi/xapi_xenops.ml +++ b/ocaml/xapi/xapi_xenops.ml @@ -1812,12 +1812,12 @@ module Events_from_xenopsd = struct Client.UPDATES.remove_barrier dbg id ; let t = with_lock active_m @@ fun () -> - if not (Hashtbl.mem active id) then ( - warn "Events_from_xenopsd.wakeup: unknown id %d" id ; - None - ) else - let t = Hashtbl.find active id in - Hashtbl.remove active id ; Some t + match Hashtbl.find_opt active id with + | Some t -> + Hashtbl.remove active id ; Some t + | None -> + warn "Events_from_xenopsd.wakeup: unknown id %d" id ; + None in Option.iter (fun t -> diff --git a/ocaml/xapi/xha_interface.ml b/ocaml/xapi/xha_interface.ml index 979ef9288e3..608ae9a64a2 100644 --- a/ocaml/xapi/xha_interface.ml +++ b/ocaml/xapi/xha_interface.ml @@ -276,10 +276,12 @@ module LiveSetInformation = struct | Xml.Element ("host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf "Missig entry '%s' within 'host' element" x) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf "Missig entry '%s' within 'host' element" x) in let bool s = try bool_of_string (String.lowercase_ascii s) @@ -326,12 +328,14 @@ module LiveSetInformation = struct | Xml.Element ("host_raw_data", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'host_raw_data' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'host_raw_data' element" x + ) in let int s = try int_of_string (String.lowercase_ascii s) @@ -382,12 +386,15 @@ module LiveSetInformation = struct | Xml.Element ("warning_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'warning_on_local_host' element" x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'warning_on_local_host' element" + x + ) in let bool x = find x = "TRUE" in Some @@ -423,14 +430,16 @@ module LiveSetInformation = struct | Xml.Element ("raw_status_on_local_host", _, children) -> let table = hash_table_of_leaf_xml_element_list children in let find x = - try Hashtbl.find table x - with Not_found -> - invalid_arg - (Printf.sprintf - "Missing entry '%s' within 'raw_status_on_local_host' \ - element" - x - ) + match Hashtbl.find_opt table x with + | Some x -> + x + | None -> + invalid_arg + (Printf.sprintf + "Missing entry '%s' within 'raw_status_on_local_host' \ + element" + x + ) in let int s = try int_of_string (String.lowercase_ascii s) diff --git a/ocaml/xapi/xha_scripts.ml b/ocaml/xapi/xha_scripts.ml index f5c2cae514e..c8f87e412c1 100644 --- a/ocaml/xapi/xha_scripts.ml +++ b/ocaml/xapi/xha_scripts.ml @@ -60,7 +60,13 @@ let ha_script_m = Mutex.create () let call_script ?log_output script args = let path = ha_dir () in let script' = Filename.concat path script in - let env = [|Printf.sprintf "PATH=%s:%s" (Sys.getenv "PATH") path|] in + let env = + [| + Printf.sprintf "PATH=%s:%s" + (Option.value (Sys.getenv_opt "PATH") ~default:"") + path + |] + in try Xapi_stdext_threads.Threadext.Mutex.execute ha_script_m (fun () -> Helpers.call_script ?log_output ~env script' args diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml index 9265084e020..4cf580ed590 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml @@ -96,8 +96,11 @@ let get_sr_rrd_handler (req : Http.Request.t) (s : Unix.file_descr) _ = let rrd = with_lock mutex (fun () -> let rrdi = - try Hashtbl.find sr_rrds sr_uuid - with Not_found -> failwith "No SR RRD available!" + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some x -> + x + | None -> + failwith "No SR RRD available!" in Rrd.copy_rrd rrdi.rrd ) diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml index cb356f5bee4..f6a9fa43646 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_monitor.ml @@ -138,31 +138,31 @@ let update_rrds timestamp dss uuid_domids paused_vms = in let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in - try - let domid = StringMap.find vm_uuid uuid_domids in + match StringMap.find_opt vm_uuid uuid_domids with + | Some domid -> ( (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find vm_rrds vm_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; - (* CA-34383: Memory updates from paused domains serve no useful - purpose. During a migrate such updates can also cause undesirable - discontinuities in the observed value of memory_actual. Hence, we - ignore changes from paused domains: *) - if not (StringSet.mem vm_uuid paused_vms) then ( - Rrd.ds_update_named rrd timestamp ~new_domid:(domid <> rrdi.domid) - named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- domid - ) - with - | Not_found -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} ; + (* CA-34383: Memory updates from paused domains serve no useful + purpose. During a migrate such updates can also cause undesirable + discontinuities in the observed value of memory_actual. Hence, we + ignore changes from paused domains: *) + if not (StringSet.mem vm_uuid paused_vms) then ( + Rrd.ds_update_named rrd timestamp + ~new_domid:(domid <> rrdi.domid) named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- domid + ) + | None -> debug "%s: Creating fresh RRD for VM uuid=%s" __FUNCTION__ vm_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace vm_rrds vm_uuid {rrd; dss; domid} - | e -> - raise e - with _ -> log_backtrace () + ) + | None -> + info "%s: VM uuid=%s is not resident in this host, ignoring rrds" + __FUNCTION__ vm_uuid in let process_sr sr_uuid dss = let named_updates = @@ -171,20 +171,17 @@ let update_rrds timestamp dss uuid_domids paused_vms = let dss = StringMap.to_seq dss |> Seq.map snd |> List.of_seq in try (* First, potentially update the rrd with any new default dss *) - try - let rrdi = Hashtbl.find sr_rrds sr_uuid in - let rrd = merge_new_dss rrdi.rrd dss in - Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; - Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; - rrdi.dss <- dss ; - rrdi.domid <- 0 - with - | Not_found -> + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrdi -> + let rrd = merge_new_dss rrdi.rrd dss in + Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} ; + Rrd.ds_update_named rrd timestamp ~new_domid:false named_updates ; + rrdi.dss <- dss ; + rrdi.domid <- 0 + | None -> debug "%s: Creating fresh RRD for SR uuid=%s" __FUNCTION__ sr_uuid ; let rrd = create_fresh_rrd !use_min_max dss in Hashtbl.replace sr_rrds sr_uuid {rrd; dss; domid= 0} - | e -> - raise e with _ -> log_backtrace () in let process_host dss = diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml index e7556381c8e..f3f56003dad 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_server.ml @@ -24,13 +24,13 @@ open D let archive_sr_rrd (sr_uuid : string) : string = let sr_rrd = with_lock mutex (fun () -> - try - let rrd = Hashtbl.find sr_rrds sr_uuid in - Hashtbl.remove sr_rrds sr_uuid ; - rrd - with Not_found -> - let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in - raise (Rrdd_error (Archive_failed msg)) + match Hashtbl.find_opt sr_rrds sr_uuid with + | Some rrd -> + Hashtbl.remove sr_rrds sr_uuid ; + rrd + | None -> + let msg = Printf.sprintf "No RRD found for SR: %s." sr_uuid in + raise (Rrdd_error (Archive_failed msg)) ) in try @@ -85,11 +85,13 @@ let archive_rrd vm_uuid (remote_address : string option) : unit = remote_address in with_lock mutex (fun () -> - try - let rrd = (Hashtbl.find vm_rrds vm_uuid).rrd in - Hashtbl.remove vm_rrds vm_uuid ; - archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () - with Not_found -> () + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> + let rrd = x.rrd in + Hashtbl.remove vm_rrds vm_uuid ; + archive_rrd_internal ~transport ~uuid:vm_uuid ~rrd () + | None -> + () ) (** This functionality is used by xapi to backup rrds to local disk or to the @@ -294,29 +296,27 @@ let remove_rrd (uuid : string) : unit = is assumed to be valid, since it is set by monitor_master. *) let migrate_rrd (session_id : string option) (remote_address : string) (vm_uuid : string) (host_uuid : string) : unit = - try - let rrdi = - with_lock mutex (fun () -> - let rrdi = Hashtbl.find vm_rrds vm_uuid in + with_lock mutex (fun () -> + match Hashtbl.find_opt vm_rrds vm_uuid with + | Some x -> debug "Sending RRD for VM uuid=%s to remote host %s for migrate" vm_uuid host_uuid ; Hashtbl.remove vm_rrds vm_uuid ; - rrdi - ) - in - let transport = - Xmlrpc_client.( - SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) - ) - in - send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid - ~rrd:rrdi.rrd () - with - | Not_found -> - debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; - log_backtrace () - | _ -> - log_backtrace () + Some x + | None -> + debug "VM %s RRDs not found on migrate! Continuing anyway..." vm_uuid ; + log_backtrace () ; + None + ) + |> Option.iter (fun rrdi -> + let transport = + Xmlrpc_client.( + SSL (SSL.make ~verify_cert:None (), remote_address, !https_port) + ) + in + send_rrd ?session_id ~transport ~to_archive:false ~uuid:vm_uuid + ~rrd:rrdi.rrd () + ) (* Called on host shutdown/reboot to send the Host RRD to the master for backup. Note all VMs will have been shutdown by now. *) @@ -756,11 +756,12 @@ module Plugin = struct process its output at most once more. *) let deregister (uid : P.uid) : unit = with_lock registered_m (fun _ -> - if Hashtbl.mem registered uid then ( - let plugin = Hashtbl.find registered uid in - plugin.reader.Rrd_reader.cleanup () ; - Hashtbl.remove registered uid - ) + Option.iter + (fun plugin -> + plugin.reader.Rrd_reader.cleanup () ; + Hashtbl.remove registered uid + ) + (Hashtbl.find_opt registered uid) ) (* Read, parse, and combine metrics from all registered plugins. *) diff --git a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml index 80691b0ab9d..dbfbd8cb73b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/xcp_rrdd.ml @@ -619,11 +619,9 @@ let dss_mem_vms doms = ) in let memory_target_opt = - try - with_lock Rrdd_shared.memory_targets_m (fun _ -> - Some (Hashtbl.find Rrdd_shared.memory_targets domid) - ) - with Not_found -> None + with_lock Rrdd_shared.memory_targets_m (fun _ -> + Hashtbl.find_opt Rrdd_shared.memory_targets domid + ) in let mem_target_ds = Option.map diff --git a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml index c718a033d0f..b8c60edec7e 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml +++ b/ocaml/xcp-rrdd/bin/rrdp-iostat/rrdp_iostat.ml @@ -192,11 +192,9 @@ module Iostat = struct (* Now read the values out of dev_values_map for devices for which we have data *) List.filter_map (fun dev -> - if not (Hashtbl.mem dev_values_map dev) then - None - else - let values = Hashtbl.find dev_values_map dev in - Some (dev, values) + Option.map + (fun values -> (dev, values)) + (Hashtbl.find_opt dev_values_map dev) ) devs end @@ -371,13 +369,13 @@ let exec_tap_ctl_list () : ((string * string) * int) list = (* Look up SR and VDI uuids from the physical path *) if not (Hashtbl.mem phypath_to_sr_vdi phypath) then refresh_phypath_to_sr_vdi () ; - if not (Hashtbl.mem phypath_to_sr_vdi phypath) then ( - (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) - D.error "Could not find device with physical path %s" phypath ; - None - ) else - let sr, vdi = Hashtbl.find phypath_to_sr_vdi phypath in - Some (pid, (minor, (sr, vdi))) + match Hashtbl.find_opt phypath_to_sr_vdi phypath with + | Some (sr, vdi) -> + Some (pid, (minor, (sr, vdi))) + | None -> + (* Odd: tap-ctl mentions a device that's not linked from /dev/sm/phy *) + D.error "Could not find device with physical path %s" phypath ; + None in let process_line str = try Scanf.sscanf str "pid=%d minor=%d state=%s args=%s@:%s" extract_vdis diff --git a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml index 6c2c11192fb..17b55481410 100644 --- a/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml +++ b/ocaml/xcp-rrdd/lib/plugin/rrdd_plugin.ml @@ -50,8 +50,9 @@ let signal_name signum = List.iter (fun (str, key) -> Hashtbl.add t key str) map ; t in - try Hashtbl.find signals signum - with Not_found -> Printf.sprintf "unknown signal (%d)" signum + Option.value + (Hashtbl.find_opt signals signum) + ~default:(Printf.sprintf "unknown signal (%d)" signum) module Utils = Utils diff --git a/ocaml/xcp-rrdd/lib/rrdd/stats.ml b/ocaml/xcp-rrdd/lib/rrdd/stats.ml index b85a9181c7a..c1996dd4e49 100644 --- a/ocaml/xcp-rrdd/lib/rrdd/stats.ml +++ b/ocaml/xcp-rrdd/lib/rrdd/stats.ml @@ -74,10 +74,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xe-cli/newcli.ml b/ocaml/xe-cli/newcli.ml index fba971ba724..412e1c95df0 100644 --- a/ocaml/xe-cli/newcli.ml +++ b/ocaml/xe-cli/newcli.ml @@ -280,7 +280,9 @@ let parse_args = (List.filter (fun (k, v) -> not (set_keyword (k, v))) rcs) in let extras = - let extra_args = try Sys.getenv "XE_EXTRA_ARGS" with Not_found -> "" in + let extra_args = + Option.value (Sys.getenv_opt "XE_EXTRA_ARGS") ~default:"" + in let l = ref [] and pos = ref 0 and i = ref 0 in while !pos < String.length extra_args do if extra_args.[!pos] = ',' then ( diff --git a/ocaml/xe-cli/options.ml b/ocaml/xe-cli/options.ml index e089a30c164..f19067bf3fa 100644 --- a/ocaml/xe-cli/options.ml +++ b/ocaml/xe-cli/options.ml @@ -34,7 +34,7 @@ let parse_lines ls = let read_rc () = try - let home = Sys.getenv "HOME" in + let home = Option.value (Sys.getenv_opt "HOME") ~default:"" in let rc_file = open_in (home ^ "/.xe") in let rec getlines cur = try diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 0eb6ef5ac1b..a8b10706504 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1061,7 +1061,8 @@ let xenconsoles = let vncviewer_binary = let n = "vncviewer" in let dirs = - Re.Str.split_delim (Re.Str.regexp_string ":") (Unix.getenv "PATH") + Re.Str.split_delim (Re.Str.regexp_string ":") + (Option.value (Sys.getenv_opt "PATH") ~default:"") in List.fold_left (fun result dir -> diff --git a/ocaml/xenopsd/list_domains/list_domains.ml b/ocaml/xenopsd/list_domains/list_domains.ml index 22d18543310..2a4ae05b2ca 100644 --- a/ocaml/xenopsd/list_domains/list_domains.ml +++ b/ocaml/xenopsd/list_domains/list_domains.ml @@ -99,9 +99,11 @@ let hashtbl_of_domaininfo x : (string, string) Hashtbl.t = let select table keys = List.map (fun key -> - if not (Hashtbl.mem table key) then - failwith (Printf.sprintf "Failed to find key: %s" key) ; - Hashtbl.find table key + match Hashtbl.find_opt table key with + | Some x -> + x + | None -> + failwith (Printf.sprintf "Failed to find key: %s" key) ) keys diff --git a/ocaml/xenopsd/xc/device.ml b/ocaml/xenopsd/xc/device.ml index 6d47a2489ef..20f2405a7e7 100644 --- a/ocaml/xenopsd/xc/device.ml +++ b/ocaml/xenopsd/xc/device.ml @@ -2786,10 +2786,9 @@ module Backend = struct Hashtbl.remove ftod (Qmp_protocol.to_fd c) ; Hashtbl.remove dtoc domid - let domid_of fd = try Some (Hashtbl.find ftod fd) with Not_found -> None + let domid_of fd = Hashtbl.find_opt ftod fd - let channel_of domid = - try Some (Hashtbl.find dtoc domid) with Not_found -> None + let channel_of domid = Hashtbl.find_opt dtoc domid end (** File-descriptor event monitor implementation for the epoll library *) diff --git a/ocaml/xenopsd/xc/readln.ml b/ocaml/xenopsd/xc/readln.ml index 9ee995723db..928b289881c 100644 --- a/ocaml/xenopsd/xc/readln.ml +++ b/ocaml/xenopsd/xc/readln.ml @@ -11,7 +11,9 @@ let read fd = let buffer = Bytes.make buffer_size '\000' in match Unix.read fd buffer 0 buffer_size with | 0 -> - let pending = try Hashtbl.find input fd with Not_found -> Bytes.empty in + let pending = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty + in Hashtbl.remove input fd ; if pending = Bytes.empty then EOF @@ -21,25 +23,26 @@ let read fd = (Bytes.to_string pending) ) | n -> - let data = Bytes.sub buffer 0 n in - let inpt = try Hashtbl.find input fd with Not_found -> Bytes.empty in - Hashtbl.replace input fd (Bytes.cat inpt data) ; - let rec loop msgs = - let data = Hashtbl.find input fd in - (* never fails *) - match Bytes.index data '\n' with - | exception Not_found -> - Ok (List.rev msgs) - | index -> + let rec loop msgs data = + match Bytes.index_opt data '\n' with + | None -> + (List.rev msgs, data) + | Some index -> let remain = Bytes.sub data (index + 1) (Bytes.length data - index - 1) in - Hashtbl.replace input fd remain ; - (* reset input *) - loop (Bytes.sub_string data 0 index :: msgs) - (* store msg *) + loop + (Bytes.sub_string data 0 index :: msgs) + remain (* reset input *) + in + let data = Bytes.sub buffer 0 n in + let inpt = + Option.value (Hashtbl.find_opt input fd) ~default:Bytes.empty in - loop [] + let inp_data = Bytes.cat inpt data in + let res, data = loop [] inp_data in + Hashtbl.replace input fd data ; + Ok res | exception Unix.Unix_error (error, _, _) -> Error (Unix.error_message error) diff --git a/ocaml/xenopsd/xc/stats.ml b/ocaml/xenopsd/xc/stats.ml index 4e25cdca45f..e551e81aaf9 100644 --- a/ocaml/xenopsd/xc/stats.ml +++ b/ocaml/xenopsd/xc/stats.ml @@ -76,10 +76,9 @@ let sample (name : string) (x : float) : unit = let x' = log x in with_lock timings_m (fun () -> let p = - if Hashtbl.mem timings name then - Hashtbl.find timings name - else - Normal_population.empty + Option.value + (Hashtbl.find_opt timings name) + ~default:Normal_population.empty in let p' = Normal_population.sample p x' in Hashtbl.replace timings name p' @@ -143,17 +142,19 @@ let log_db_call task_opt dbcall ty = dbstats_drop_dbcalls in Hashtbl.replace hashtbl dbcall - (1 + try Hashtbl.find hashtbl dbcall with _ -> 0) ; + (1 + Option.value (Hashtbl.find_opt hashtbl dbcall) ~default:0) ; let threadid = Thread.id (Thread.self ()) in Hashtbl.replace dbstats_threads threadid ((dbcall, ty) - :: (try Hashtbl.find dbstats_threads threadid with _ -> []) + :: Option.value + (Hashtbl.find_opt dbstats_threads threadid) + ~default:[] ) ; match task_opt with | Some task -> Hashtbl.replace dbstats_task task ((dbcall, ty) - :: (try Hashtbl.find dbstats_task task with _ -> []) + :: Option.value (Hashtbl.find_opt dbstats_task task) ~default:[] ) | None -> () diff --git a/ocaml/xenopsd/xc/xenops_server_xen.ml b/ocaml/xenopsd/xc/xenops_server_xen.ml index a3317194f24..44d4e4e942c 100644 --- a/ocaml/xenopsd/xc/xenops_server_xen.ml +++ b/ocaml/xenopsd/xc/xenops_server_xen.ml @@ -961,10 +961,7 @@ module HOST = struct get_lines () ; close_in in_chan ; let find key = - if Hashtbl.mem tbl key then - Hashtbl.find tbl key - else - "unknown" + Option.value (Hashtbl.find_opt tbl key) ~default:"unknown" in ( find "vendor_id" , find "model name" diff --git a/ocaml/xsh/xsh.ml b/ocaml/xsh/xsh.ml index 4f563373857..982ff6c346f 100644 --- a/ocaml/xsh/xsh.ml +++ b/ocaml/xsh/xsh.ml @@ -100,7 +100,11 @@ let _ = let host = Sys.argv.(1) in let cmd = Sys.argv.(2) in let session = - try Sys.getenv "XSH_SESSION" with _ -> failwith "Session not provided" + match Sys.getenv_opt "XSH_SESSION" with + | Some x -> + x + | None -> + failwith "Session not provided" in let args = List.map diff --git a/quality-gate.sh b/quality-gate.sh index 33f54e26e54..a5072f7a46d 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -93,6 +93,31 @@ ocamlyacc () { fi } + +unixgetenv () { + N=1 + UNIXGETENV=$(git grep -P -r -o --count 'getenv(?!_opt)' -- **/*.ml | wc -l) + if [ "$UNIXGETENV" -eq "$N" ]; then + echo "OK found $UNIXGETENV usages of exception-raising Unix.getenv in OCaml files." + else + echo "ERROR expected $N usages of exception-raising Unix.getenv in OCaml files, got $UNIXGETENV" 1>&2 + exit 1 + fi +} + +hashtblfind () { + N=36 + # Looks for all .ml files except the ones using Core.Hashtbl.find, + # which already returns Option + HASHTBLFIND=$(git grep -P -r --count 'Hashtbl.find(?!_opt)' -- '**/*.ml' ':!ocaml/xapi-storage-script/main.ml' | cut -d ':' -f 2 | paste -sd+ - | bc) + if [ "$HASHTBLFIND" -eq "$N" ]; then + echo "OK counted $HASHTBLFIND usages of exception-raising Hashtbl.find" + else + echo "ERROR expected $N usages of exception-raising Hashtbl.find, got $HASHTBLFIND" 1>&2 + exit 1 + fi +} + unnecessary-length () { N=0 local_grep () { @@ -120,5 +145,7 @@ structural-equality vtpm-unimplemented vtpm-fields ocamlyacc +unixgetenv +hashtblfind unnecessary-length