type t = { number: int; } (* FIXME: maybe this should be an optional parameter? *) let sys_mount_point = "/sys" let of_node path = {number = if path = "/dev/root" then (Unix.stat "/").Unix.st_dev else (Unix.stat path).Unix.st_rdev} let of_path path = {number = (Unix.stat path).Unix.st_dev} let of_devno devno = {number = devno} let to_devno dev = dev.number let major dev = (to_devno dev) lsr 8 let minor dev = (to_devno dev) land 0xff let of_major_minor major minor = of_devno ((major lsl 8) lor minor) let parse_sys_dev_file path = let a = Pcre.extract ~pat:"^([0-9]+):([0-9]+)\n$" (File.to_string path) in int_of_string a.(1) lsl 8 + int_of_string a.(2) let of_syspath path = of_devno (parse_sys_dev_file (path ^ "/dev")) let sysdir = let sysdir_guess = Hashtbl.create 32 in function {number = devno} -> try let dir = Hashtbl.find sysdir_guess devno in if parse_sys_dev_file (sys_mount_point ^ dir ^ "/dev") = devno then dir else raise Not_found with _ -> (* We either didn't find the device in the table, or we found the wrong device. Refresh the cache and try again. *) Hashtbl.clear sysdir_guess; Stream.iter (fun (path, _) -> if Filename.basename path = "dev" then Hashtbl.replace sysdir_guess (parse_sys_dev_file path) (String2.drop_prefix sys_mount_point (Filename.dirname path))) (Dir.rstream (sys_mount_point ^ "/block")); Hashtbl.find sysdir_guess devno let sysname dev = Filename.basename (sysdir dev) let of_sysname = let device_guess = Hashtbl.create 32 in fun name -> try let dev = Hashtbl.find device_guess name in if sysname dev = name then dev else raise Not_found with _ -> (* We either didn't find the name in the table or we found the wrong name. Refresh the cache and try again. *) Hashtbl.clear device_guess; Stream.iter (fun (dir, _) -> if Filename.basename dir = "dev" then Hashtbl.replace device_guess (Filename.basename (Filename.dirname dir)) (of_devno (parse_sys_dev_file dir))) (Dir.rstream (sys_mount_point ^ "/block")); Hashtbl.find device_guess name let node = let node_guess = Hashtbl.create 32 in function {number = devno} -> try let node = Hashtbl.find node_guess devno in let stat = Unix.stat node in if stat.Unix.st_kind = Unix.S_BLK && stat.Unix.st_rdev = devno then node else raise Not_found with _ -> (* If we can't find a node in /dev, this is may be a rootfs which has major number zero. *) (* /dev/root is not present in etch. *) (*if devno = (Unix.stat "/").Unix.st_dev then "/dev/root" else*) begin (* We either didn't find the node in the table or we found the wrong node. Refresh the cache and try again. *) Hashtbl.clear node_guess; Stream.iter (fun (path, info) -> if String2.has_prefix "/dev/.static/" path || String2.has_prefix "/dev/.udevdb/" path then () else if info.Unix.LargeFile.st_kind = Unix.S_BLK then Hashtbl.replace node_guess info.Unix.LargeFile.st_rdev path) (Dir.rstream "/dev"); Hashtbl.find node_guess devno end let path device = node device let compare a b = a.number - b.number let eq a b = compare a b = 0 let split_part name = let a = Pcre.extract ~pat:"^(.*[^0-9])([0-9]+)" name in a.(1), int_of_string a.(2) let partition_number device = let name = sysname device in snd (split_part name) let disk_of_part part = let drive = fst (split_part (sysname part)) in of_syspath (sys_mount_point ^ "/block/" ^ drive) let root_part () = of_path "/" let is_root_part partition = partition = root_part () let get_all () = List.map of_syspath (List.map Filename.dirname (Sh.to_linelist ("find " ^ sys_mount_point ^ "/block -name dev"))) let try_of_node node = try Some (of_node node) with _ -> None (** Construct several devices filtering out failures. *) let of_nodes paths = Option.filter (List.map try_of_node paths) (** Return a list of all the block device paths *) let dev_list () = of_nodes (Dir.path_list "/dev/disk/by-path") let group_disk_id () = (Unix.getgrnam "disk").Unix.gr_gid let is_disk dev = (Unix.stat (path dev)).Unix.st_gid = group_disk_id () let is_on_a_disk dev = try (Unix.stat (path (disk_of_part dev))).Unix.st_gid = group_disk_id () with _ -> false let try_partition_number dev = try Some (partition_number dev) with _ -> None let is_part dev = match try_partition_number dev with Some _ -> true | None -> false let get_all_disks () = List.filter (fun dev -> not (is_part dev)) (List.filter is_disk (dev_list ())) let get_all_partitions () = List.filter is_part (List.filter is_on_a_disk (dev_list ())) let group_cdrom_id () = (Unix.getgrnam "cdrom").Unix.gr_gid let is_cdrom dev = (Unix.stat (path dev)).Unix.st_gid = group_cdrom_id () let get_all_cdroms () = List.filter is_cdrom (dev_list ()) let group_floppy_id () = (Unix.getgrnam "floppy").Unix.gr_gid (* Used for removable media I think. *) let is_floppy dev = (Unix.stat (path dev)).Unix.st_gid = group_floppy_id () let get_all_removable () = List.filter is_floppy (dev_list ()) (* Be careful - mounts can pile up and obscure each other, we need to verify that each file we look at is on the right file system. I'm going to give up trying to honor the fstab of every partition we are trying to load from. It is too much madness for not enough gain. *) let to_devname = let devname_guess = Hashtbl.create 32 in fun {number = devno} -> let major = devno lsr 8 in try Some (Hashtbl.find devname_guess major) with _ -> Hashtbl.clear devname_guess; let device_list_path = "/proc/devices" in let a = Pcre.extract ~full_match:false ~pat:"^.*Character devices:\n((.|\n)*)\nBlock devices:\n((.|\n)*)$" (File.to_string device_list_path) in let blockdevs = List.map (fun dev -> let a = Pcre.extract ~full_match:false ~pat:"^[ ]*([0-9]+)[ ]+(.*)$" dev in int_of_string a.(0), a.(1)) (Pcre.split ~pat:"\n" a.(2)) in List.iter (fun (num, name) -> Hashtbl.replace devname_guess num name) blockdevs; try Some (Hashtbl.find devname_guess major) with _ -> None let make_blkid_functions () = let parse_line line = try let re = Pcre.regexp "^([^:]*):[ ]*(([^ =]+=\"[^\"]*\"[ ]+)*)$" and sep = Pcre.regexp "\" " and eq = Pcre.regexp "=\"" in let a = Pcre.extract ~rex:re ~full_match:false line in let dev = of_node a.(0) and info = Option.filter (List.map (fun pair -> match Pcre.split ~rex:eq ~max:(-1) pair with [attr; ""] -> None | [attr; value] -> Some (attr, value) | _ -> None) (Pcre.split ~rex:sep ~max:(-1) a.(1))) in Some (dev, info) with _ -> None in let cmd = "blkid -c /dev/null" in let lines = Sh.to_linelist cmd in let alists = Option.filter (List.map parse_line lines) in ((fun dev -> List.assoc dev alists), (fun dev tag -> List.assoc tag (List.assoc dev alists)), (fun uuid -> fst (List.find (fun (dev, info) -> try List.assoc "UUID" info = uuid with _ -> false) alists)), (fun label -> List.map fst (List.filter (fun (dev, info) -> try List.assoc "LABEL" info = label with _ -> false) alists))) (* This is the same mechanism as is used in the Lazy2.cache function, but here we construct four functions from a single (expensive) invocation of blkid. Therefore we need to extend the cache function in an ad-hoc way. *) let (update_blkid_fns, get_blkid_alist, get_blkid_info, device_of_uuid, devices_of_label) = let cache = ref (lazy (make_blkid_functions ())) in ((fun () -> cache := lazy (make_blkid_functions ())), (fun dev -> ((fun (x,_,_,_) -> x) (Lazy.force !cache)) dev), (fun dev tag -> ((fun (_,x,_,_) -> x) (Lazy.force !cache)) dev tag), (fun uuid -> ((fun (_,_,x,_) -> x) (Lazy.force !cache)) uuid), (fun label -> ((fun (_,_,_,x) -> x) (Lazy.force !cache)) label)) let update () = update_blkid_fns ()