-(* guestfs_lstatlist has a "hidden" limit of the protocol message size.
- * Call this function, but split the list of names into chunks.
- *)
-and lstatlist_wrapper g dir = function
- | [] -> []
- | names ->
- let names', names = List.take 1000 names, List.drop 1000 names in
- let xs = g#lstatlist dir (Array.of_list names') in
- let xs = Array.to_list xs in
- xs @ lstatlist_wrapper g dir names
-
-(* For each entry which is a symlink, read the destination of the
- * symlink. This is non-trivial because on Windows we cannot use
- * readlink but need to instead parse the reparse data from NTFS.
- *)
-and readlink_wrapper g dir names stats =
- (* Is the directory on an NTFS filesystem? *)
- let dev = get_mounted_device g dir in
- if g#vfs_type dev <> "ntfs" then (
- (* Not NTFS, use the fast g#readlinklist method. *)
- let rec readlinklist_wrapper g dir = function
- | [] -> []
- | names ->
- let names', names = List.take 1000 names, List.drop 1000 names in
- let xs = g#readlinklist dir (Array.of_list names') in
- let xs = Array.to_list xs in
- xs @ readlinklist_wrapper g dir names
- in
- readlinklist_wrapper g dir names
- )
- else (
- (* NTFS: look up each symlink individually. *)
- List.map (
- fun (name, stat) ->
- if not (is_symlink stat.G.mode) then ""
- else
- let path = if dir = "/" then dir ^ name else dir ^ "/" ^ name in
- try
- let _, display = get_ntfs_reparse_data g path in
- display
- with exn ->
- debug "get_ntfs_reparse_data: %s: failed: %s"
- path (Printexc.to_string exn);
- "?"
- ) (List.combine names stats)
- )
-
-(* See:
- * https://bugzilla.redhat.com/show_bug.cgi?id=663407
- * http://git.annexia.org/?p=libguestfs.git;a=commit;h=3a3836b933b80c4f9f2c767fda4f8b459f998db2
- * http://www.tuxera.com/community/ntfs-3g-advanced/junction-points-and-symbolic-links/
- * http://www.tuxera.com/community/ntfs-3g-advanced/extended-attributes/
- * http://www.codeproject.com/KB/winsdk/junctionpoints.aspx
- *)
-and get_ntfs_reparse_data g path =
- let data = g#lgetxattr path "system.ntfs_reparse_data" in
- let link, display =
- bitmatch Bitstring.bitstring_of_string data with
- (* IO_REPARSE_TAG_MOUNT_POINT *)
- | { 0xa0000003_l : 32 : littleendian;
- _ : 16 : littleendian; (* data length - ignore it *)
- _ : 16 : littleendian; (* reserved *)
- link_offset : 16 : littleendian;
- link_len : 16 : littleendian;
- display_offset : 16 : littleendian;
- display_len : 16 : littleendian;
- link : link_len * 8 :
- string, offset (8 * (link_offset + 0x10));
- display : display_len * 8 :
- string, offset (8 * (display_offset + 0x10)) } ->
- (* These strings should always be valid UTF16LE, but the caller
- * is prepared to catch any exception if this fails.
- *)
- let link = windows_string_to_utf8 link in
- let display = windows_string_to_utf8 display in
- link, display
- | { 0xa0000003_l : 32 : littleendian } ->
- invalid_arg (
- sprintf "%s: could not parse IO_REPARSE_TAG_MOUNT_POINT data" path
- )
-
- (* IO_REPARSE_TAG_SYMLINK *)
- | { 0xa000000c_l : 32 : littleendian;
- _ : 16 : littleendian; (* data length - ignore it *)
- _ : 16 : littleendian; (* reserved *)
- link_offset : 16 : littleendian;
- link_len : 16 : littleendian;
- display_offset : 16 : littleendian;
- display_len : 16 : littleendian;
- link : link_len * 8 :
- string, offset (8 * (link_offset + 0x14));
- display : display_len * 8 :
- string, offset (8 * (display_offset + 0x14)) } ->
- let link = windows_string_to_utf8 link in
- let display = windows_string_to_utf8 display in
- link, display
- | { 0xa000000c_l : 32 : littleendian } ->
- invalid_arg (
- sprintf "%s: could not parse IO_REPARSE_TAG_SYMLINK data" path
- )
-
- | { i : 32 : littleendian } ->
- invalid_arg (
- sprintf "%s: reparse data of type 0x%lx is not supported" path i
- )
- | { _ } ->
- invalid_arg (sprintf "%s: reparse data is too short" path) in
-
- link, display
-
-(* Given a path which is located somewhere on a mountpoint, return the
- * device name. This works by using g#mountpoints and then looking for
- * the mount path with the longest match.
- *)
-and get_mounted_device g path =
- let mps = g#mountpoints () in
- let mps = List.map (
- fun (dev, mp) ->
- if String.starts_with path mp then dev, String.length mp else dev, 0
- ) mps in
- let cmp (_,n1) (_,n2) = compare n2 n1 in
- let mps = List.sort ~cmp mps in
- match mps with
- | [] ->
- invalid_arg (sprintf "%s: not mounted" path)
- | (_,0) :: _ ->
- invalid_arg (sprintf "%s: not found on any filesystem" path)
- | (dev,_) :: _ -> dev
-