diff --git a/discover/discover.ml b/discover/discover.ml index a0ea7fe..cf02745 100644 --- a/discover/discover.ml +++ b/discover/discover.ml @@ -78,6 +78,7 @@ let config_includes = [ "caml/unixsupport.h"; "caml/signals.h"; "caml/alloc.h"; + "caml/callback.h"; "caml/custom.h"; "caml/bigarray.h"; "caml/version.h"; @@ -229,6 +230,16 @@ let features = D "S_IFREG"; S "fstatat"; S "openat"; S "unlinkat"; S "renameat"; S "mkdirat"; S "linkat"; S "symlinkat"; S "readlinkat"; S "fchownat"; S "fchmodat"; ]; + "RENAMEAT2", L[ + fd_int; + DEFINE "_GNU_SOURCE"; + I "fcntl.h"; I "stdio.h"; + S "renameat2"; + ]; + "RENAME_WHITEOUT", L[ + DEFINE "_GNU_SOURCE"; + D "RENAME_WHITEOUT"; + ]; "DIRFD", L[ fd_int; I "sys/types.h"; diff --git a/ppx_have/ppx_have.ml b/ppx_have/ppx_have.ml index b824098..2a17523 100644 --- a/ppx_have/ppx_have.ml +++ b/ppx_have/ppx_have.ml @@ -92,12 +92,43 @@ let record_external have = in externals_of#structure_item +let have_constr ~loc = + let have_constr = + object + inherit Ast_traverse.map as super + + method! constructor_declaration x = + match super#constructor_declaration x with + | { + pcd_attributes = + [ + { + attr_name = { txt = "have"; _ }; + attr_payload = PStr (cond :: _); + _; + }; + ]; + _; + } as x -> + if eval_cond ~loc cond then x + else + { + x with + pcd_name = + { x.pcd_name with txt = x.pcd_name.txt ^ "__Not_available" }; + } + | x -> x + end + in + have_constr#structure_item + let have_expand ~ctxt cond items = let loc = Expansion_context.Extension.extension_point_loc ctxt in let have = eval_cond ~loc cond in List.iter (record_external have) items; match (have, !all) with - | true, _ -> items + | true, true -> items + | true, false -> List.map (have_constr ~loc) items | false, true -> List.map (invalid_external ~loc) items | false, false -> [] diff --git a/src/dune b/src/dune index cc1c894..52cb709 100644 --- a/src/dune +++ b/src/dune @@ -51,6 +51,7 @@ pts read_cred realpath + rename resource sendmsg signalfd diff --git a/src/extUnix.pp.ml b/src/extUnix.pp.ml index 8726c35..13d1efc 100644 --- a/src/extUnix.pp.ml +++ b/src/extUnix.pp.ml @@ -13,6 +13,8 @@ the corresponding man pages and/or system documentation for details. [ENOSYS] (Not implemented) error even though the function is available. *) exception Not_available of string +let _ = Callback.register_exception "ExtUnix.Not_available" (Not_available "") + (** type of bigarray used by BA submodules that read from files into bigarrays or write bigarrays into files. The only constraint here is [Bigarray.c_layout]. @@ -211,6 +213,12 @@ external fchownat : Unix.file_descr -> string -> int -> int -> at_flag list -> u external fchmodat : Unix.file_descr -> string -> int -> at_flag list -> unit = "caml_extunix_fchmodat" ] +[%%have RENAMEAT2 +type rename_flag = RENAME_EXCHANGE | RENAME_NOREPLACE | RENAME_WHITEOUT [@have RENAME_WHITEOUT] + +external renameat2 : Unix.file_descr -> string -> Unix.file_descr -> string -> rename_flag list -> unit = "caml_extunix_renameat2" +] + (** @raise Not_available if OS does not represent file descriptors as numbers *) let int_of_file_descr : Unix.file_descr -> int = if Obj.is_block (Obj.repr Unix.stdin) then diff --git a/src/rename.c b/src/rename.c new file mode 100644 index 0000000..566dbc9 --- /dev/null +++ b/src/rename.c @@ -0,0 +1,42 @@ +#define EXTUNIX_WANT_RENAMEAT2 +#include "config.h" + +#if defined(EXTUNIX_HAVE_RENAMEAT2) + +#ifndef RENAME_WHITEOUT +#define RENAME_WHITEOUT 0 +#endif + +static const int rename_flags_table[] = { + RENAME_NOREPLACE, /* 0 */ + RENAME_EXCHANGE, /* 1 */ + RENAME_WHITEOUT, /* 2 */ +}; + +#define RENAME_WHITEOUT_INDEX 2 + +static void check_flag_list(value list) +{ + for (/*nothing*/; list != Val_emptylist; list = Field(list, 1)) + { +#if !defined(EXTUNIX_HAVE_RENAME_WHITEOUT) + if (RENAME_WHITEOUT_INDEX == Int_val(Field(list, 0))) + caml_raise_with_string(*caml_named_value("ExtUnix.Not_available"), "renameat2 RENAME_WHITEOUT"); +#endif + } +} + +CAMLprim value caml_extunix_renameat2(value v_oldfd, value v_oldname, value v_newfd, value v_newname, value v_flags) +{ + CAMLparam5(v_oldfd, v_oldname, v_newfd, v_newname, v_flags); + check_flag_list(v_flags); + int oldfd = Int_val(v_oldfd), newfd = Int_val(v_newfd); + const char *oldname = String_val(v_oldname), *newname = String_val(v_newname); + int flags = caml_convert_flag_list(v_flags, rename_flags_table); + caml_enter_blocking_section(); + int ret = renameat2(oldfd, oldname, newfd, newname, flags); + caml_leave_blocking_section(); + if (ret != 0) uerror("renameat2", v_oldname); + CAMLreturn(Val_unit); +} +#endif