Skip to content

Commit

Permalink
implement native for windows
Browse files Browse the repository at this point in the history
  • Loading branch information
kentookura committed Jun 12, 2024
1 parent 77d8810 commit 0777723
Show file tree
Hide file tree
Showing 2 changed files with 44 additions and 3 deletions.
16 changes: 14 additions & 2 deletions lib_eio_windows/fs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -187,8 +187,20 @@ end = struct

let pp f t = Fmt.string f (String.escaped t.label)

let native _t _path =
failwith "TODO: Windows native"
let native_internal t path =
if Filename.is_relative path then (
let p =
if t.dir_path = "." then path
else Filename.concat t.dir_path path
in
if p = "" then "."
else if p = "." then p
else if Filename.is_implicit p then ".\\" ^ p
else p
) else path

let native t path =
Some (native_internal t path)
end
and Handler : sig
val v : (Dir.t, [`Dir | `Close]) Eio.Resource.handler
Expand Down
31 changes: 30 additions & 1 deletion lib_eio_windows/test/test_fs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -264,6 +264,34 @@ let test_remove_dir env () =
in
()

let test_native env () =
let cwd = Sys.getcwd () ^ "\\" in
let test x =
let native = Eio.Path.native x in
let result =
native |> Option.map @@ fun native ->
if String.starts_with ~prefix:cwd native then
".\\" ^ String.sub native (String.length cwd) (String.length native - String.length cwd)
else native
in
traceln "%a -> %a" Eio.Path.pp x Fmt.(Dump.option string) result
in
test env#fs;
test (env#fs / "\\");
test (env#fs / "\\etc\\hosts");
test (env#fs / ".");
test (env#fs / "foo\\bar");
test env#cwd;
test (env#cwd / "..");
let sub = env#cwd / "native-sub" in
Eio.Path.mkdir sub ~perm:0o700;
Eio.Path.with_open_dir sub @@ fun sub ->
test sub;
test (sub / "foo.txt");
test (sub / ".");
test (sub / "..");
test (sub / "\\etc\\passwd")

let tests env = [
"create-write-read", `Quick, test_create_and_read env;
"cwd-abs-path", `Quick, test_cwd_no_access_abs env;
Expand All @@ -277,4 +305,5 @@ let tests env = [
"unlink", `Quick, test_unlink env;
"failing-unlink", `Quick, try_failing_unlink env;
"rmdir", `Quick, test_remove_dir env;
]
"native", `Quick, test_native env;
]

0 comments on commit 0777723

Please sign in to comment.