Merge pull request simonjbeaumont#2 from psafont/opt

CA-266936: Move pci lookups to string_opt to prevent some segfaults

Author: robhoes

bindings/ffi_bindings.ml

@@ -264,15 +264,15 @@ module Bindings (F : Cstubs.FOREIGN) = struct
 
   let pci_lookup_name_1_ary =
     foreign "pci_lookup_name"
-      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> returning string)
+      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> returning string_opt)
 
   let pci_lookup_name_2_ary =
     foreign "pci_lookup_name"
-      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> returning string)
+      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> returning string_opt)
 
   let pci_lookup_name_4_ary =
     foreign "pci_lookup_name"
-      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> int @-> int @-> returning string)
+      (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> int @-> int @-> returning string_opt)
 
   let pci_load_name_list =
     foreign "pci_load_name_list" (Pci_access.t @-> returning int)

examples/lspci.ml

@@ -2,23 +2,24 @@ open Pci
 
 (* This should be equivalent to `lspci -nnnDv` *)
 let lspci_nnnDv pci_access =
+  let default v = match v with Some v -> v | None -> "" in
   let devs = get_devices pci_access in
   List.iter (fun d ->
     let open Pci_dev in
     Printf.printf "Device: %04x:%02x:%02x.%d\n"
       d.domain d.bus d.dev d.func;
     Printf.printf "Class:  %s [%04x]\n"
-      (lookup_class_name pci_access d.device_class) d.device_class;
+      (lookup_class_name pci_access d.device_class |> default) d.device_class;
     Printf.printf "Vendor: %s [%04x]\n"
-      (lookup_vendor_name pci_access d.vendor_id) d.vendor_id;
+      (lookup_vendor_name pci_access d.vendor_id |> default) d.vendor_id;
     Printf.printf "Device: %s [%04x]\n"
-      (lookup_device_name pci_access d.vendor_id d.device_id) d.device_id;
+      (lookup_device_name pci_access d.vendor_id d.device_id |> default) d.device_id;
     begin match d.subsystem_id with
     | Some (sv_id, sd_id) ->
       Printf.printf "SVendor:\t%s [%04x]\n"
-        (lookup_subsystem_vendor_name pci_access sv_id) sv_id;
+        (lookup_subsystem_vendor_name pci_access sv_id |> default) sv_id;
       Printf.printf "SDevice:\t%s [%04x]\n"
-        (lookup_subsystem_device_name pci_access d.vendor_id d.device_id sv_id sd_id) sd_id
+        (lookup_subsystem_device_name pci_access d.vendor_id d.device_id sv_id sd_id |> default) sd_id
     | None -> ()
     end;
     begin match d.phy_slot with
@@ -43,7 +44,8 @@ let lspci_nnnDv pci_access =
   let nv_vid = 0x10de
   and k1_did = 0x0ff7
   and id_160 = 0x113b in
-  let n = lookup_subsystem_device_name pci_access nv_vid k1_did nv_vid id_160 in
+  let n = lookup_subsystem_device_name pci_access nv_vid k1_did nv_vid id_160
+          |> default in
   Printf.printf "\"%s\"\n" n
 
 let () = with_access lspci_nnnDv

lib/pci.mli

@@ -32,29 +32,29 @@ module Pci_access : sig
   type t
 end
 
-val lookup_class_name : Pci_access.t -> int -> string
+val lookup_class_name : Pci_access.t -> int -> string option
 (** [lookup_class_name a id] wraps pci_lookup_name with the right flags to
     lookup the name for the class whose identifier is [id] using the access
     value [a]. If [libpci] cannot find a match it returns "Class [id]". *)
 
-val lookup_progif_name : Pci_access.t -> int -> int -> string
+val lookup_progif_name : Pci_access.t -> int -> int -> string option
 (** [lookup_progif_name a c_id id] is like {!lookup_class_name} but returns
     the name of the programming interface with ID [id] within the class with ID
     [c_id]. *)
 
-val lookup_vendor_name : Pci_access.t -> int -> string
+val lookup_vendor_name : Pci_access.t -> int -> string option
 (** [lookup_vendor_name a id] is like {!lookup_class_name} but returns
     the name of the PCI vendor with ID [id]. *)
 
-val lookup_device_name : Pci_access.t -> int -> int -> string
+val lookup_device_name : Pci_access.t -> int -> int -> string option
 (** [lookup_device_name a v_id id] is like {!lookup_class_name} but returns
     the name of the device with ID [id] by the vendor with ID [v_id]. *)
 
-val lookup_subsystem_vendor_name : Pci_access.t -> int -> string
+val lookup_subsystem_vendor_name : Pci_access.t -> int -> string option
 (** [lookup_subsystem_vendor_name a id] is like {!lookup_class_name} but
     returns the name of the PCI vendor with ID [id]. *)
 
-val lookup_subsystem_device_name : Pci_access.t -> int -> int -> int -> int -> string
+val lookup_subsystem_device_name : Pci_access.t -> int -> int -> int -> int -> string option
 (** [lookup_subsystem_device_name a v_id d_id sv_id sd_id] is like
     {!lookup_class_name} but returns the name of the PCI subsystem of a device
     with ID [d_id] made by vendor with ID [v_id] whose subvendor and subdevice

lib_test/test_pci.ml

@@ -49,14 +49,15 @@ let test_lookup_functions () =
     SVendor:        Red Hat, Inc [1af4]
     SDevice:        Qemu virtual machine [1100] *)
   let test_lookup = assert_equal ~printer:(fun x -> x) in
+  let default v = match v with Some v -> v | None -> "" in
   with_dump (fun acc ->
-    test_lookup "Bridge" @@ lookup_class_name acc 0x0680;
-    test_lookup "Intel Corporation" @@ lookup_vendor_name acc 0x8086;
-    test_lookup "82371AB/EB/MB PIIX4 ACPI" @@ lookup_device_name acc 0x8086 0x7113;
-    test_lookup "Red Hat, Inc." @@ lookup_subsystem_vendor_name acc 0x1af4;
-    test_lookup "Qemu virtual machine" @@ lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100;
-    test_lookup "VGA compatible controller" @@ lookup_class_name acc 0x0300;
-    test_lookup "VGA controller" @@ lookup_progif_name acc 0x0300 0x00;
+    test_lookup "Bridge" @@ (lookup_class_name acc 0x0680 |> default);
+    test_lookup "Intel Corporation" @@ (lookup_vendor_name acc 0x8086 |> default);
+    test_lookup "82371AB/EB/MB PIIX4 ACPI" @@ (lookup_device_name acc 0x8086 0x7113 |> default);
+    test_lookup "Red Hat, Inc." @@ (lookup_subsystem_vendor_name acc 0x1af4 |> default);
+    test_lookup "Qemu virtual machine" @@ (lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100 |> default);
+    test_lookup "VGA compatible controller" @@ (lookup_class_name acc 0x0300 |> default);
+    test_lookup "VGA controller" @@ (lookup_progif_name acc 0x0300 0x00 |> default);
   )
 
 let _ =