Add Unix.descr_of_fd and Unix.descr_of_os

Changes

@@ -97,6 +97,10 @@ Working version
   (Christopher Zimmermann, review by Xavier Leroy, Damien Doligez, David
    Allsopp, David Sheets)
 
+- GPR#????: Add Unix.descr_of_fd and Unix.descr_of_os for obtaining file_descr
+  values representing fds/handles supplied outside the runtime.
+  (David Allsopp, review by ???)
+
 ### Compiler user-interface and warnings:
 
 - PR#6416, GPR#1120: unique printed names for identifiers

otherlibs/threads/unix.ml

@@ -210,7 +210,8 @@ type file_perm = int
 
 external openfile : string -> open_flag list -> file_perm -> file_descr
            = "unix_open"
-
+external descr_of_fd : int -> file_descr = "unix_descr_of_fd"
+let descr_of_os fd = descr_of_fd (Nativeint.to_int fd)
 external close : file_descr -> unit = "unix_close"
 external fsync : file_descr -> unit = "unix_fsync"
 external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read"

otherlibs/unix/Makefile

@@ -24,8 +24,8 @@ LDOPTS=$(NATIVECCLIBS)
 
 COBJS=accept.o access.o addrofstr.o alarm.o bind.o channels.o chdir.o \
   chmod.o chown.o chroot.o close.o fsync.o closedir.o connect.o cst2constr.o \
-  cstringv.o dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \
-  fchmod.o fchown.o fcntl.o fork.o ftruncate.o \
+  cstringv.o descr.o dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o \
+  exit.o fchmod.o fchown.o fcntl.o fork.o ftruncate.o \
   getaddrinfo.o getcwd.o getegid.o geteuid.o getgid.o \
   getgr.o getgroups.o gethost.o gethostname.o getlogin.o \
   getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \

otherlibs/unix/descr.c

@@ -0,0 +1,55 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 David Allsopp, OCaml Labs, Cambridge.                  */
+/*                                                                        */
+/*   Copyright 2018 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+#include <errno.h>
+
+#ifndef _WIN32
+#include <fcntl.h>
+#endif
+
+CAMLprim value unix_descr_of_fd (value fd)
+{
+  /* fcntl and _get_osfhandle will set errno to EBADF for a closed fd */
+#ifdef _WIN32
+  if (_get_osfhandle(Int_val(fd)) == -1)
+    uerror("descr_of_fd", Nothing);
+
+  return win_handle_fd(fd);
+#else
+  if (fcntl(Int_val(fd), F_GETFL) == -1)
+    uerror("descr_of_fd", Nothing);
+
+  return fd;
+#endif
+}
+
+#ifdef _WIN32
+CAMLprim value unix_descr_of_os (value vhandle)
+{
+  HANDLE handle = (HANDLE)Nativeint_val(vhandle);
+  DWORD dwFlags;
+
+  if (!GetHandleInformation(handle, &dwFlags)) {
+    errno = EBADF;
+    uerror("descr_of_os", Nothing);
+  }
+
+  return win_alloc_handle_or_socket(handle);
+}
+#endif

otherlibs/unix/unix.ml

@@ -303,6 +303,8 @@ type file_perm = int
 
 external openfile : string -> open_flag list -> file_perm -> file_descr
            = "unix_open"
+external descr_of_fd : int -> file_descr = "unix_descr_of_fd"
+let descr_of_os fd = descr_of_fd (Nativeint.to_int fd)
 external close : file_descr -> unit = "unix_close"
 external fsync : file_descr -> unit = "unix_fsync"
 external unsafe_read : file_descr -> bytes -> int -> int -> int

otherlibs/unix/unix.mli

@@ -304,6 +304,20 @@ val openfile : string -> open_flag list -> file_perm -> file_descr
    permissions to give to the file if it is created (see
    {!umask}). Return a file descriptor on the named file. *)
 
+val descr_of_fd : int -> file_descr
+(** Return a [file_descr] representing the given C fd number. This can be used
+    to get an OCaml descriptor for handles which the process knows may have been
+    provided externally. Once an fd has been passed to OCaml this way, the fd
+    should not be used from C. If access to the fd is also required in C, it is
+    better to use [dup] and maintain separate fds for C code and OCaml code
+    (this does not apply to C stub functions which should observe all the normal
+    caution of interacting with OCaml's Unix library. *)
+
+val descr_of_os : nativeint -> file_descr
+(** On Unix, identical to {!descr_of_fd}. On Windows, this allows a native
+    Windows API HANDLE to be converted to a file_descr. The same restrictions on
+    subsequent use of the handle from C apply. *)
+
 val close : file_descr -> unit
 (** Close a file descriptor. *)
 

otherlibs/win32unix/Makefile

@@ -30,7 +30,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
 
 # Files from the ../unix directory
 UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
-  cstringv.c execv.c execve.c execvp.c \
+  cstringv.c descr.c execv.c execve.c execvp.c \
   exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
   getnameinfo.c getproto.c \
   getserv.c gmtime.c mmap_ba.c putenv.c rmdir.c \

otherlibs/win32unix/unix.ml

@@ -181,6 +181,8 @@ type file_perm = int
 
 external openfile : string -> open_flag list -> file_perm -> file_descr
            = "unix_open"
+external descr_of_fd : int -> file_descr = "unix_descr_of_fd"
+external descr_of_os : nativeint -> file_descr = "unix_descr_of_os"
 external close : file_descr -> unit = "unix_close"
 external fsync : file_descr -> unit = "unix_fsync"
 external unsafe_read : file_descr -> bytes -> int -> int -> int

otherlibs/win32unix/unixsupport.c

@@ -70,8 +70,6 @@ value win_alloc_socket(SOCKET s)
   return res;
 }
 
-#if 0
-/* PR#4750: this function is no longer used */
 value win_alloc_handle_or_socket(HANDLE h)
 {
   value res = win_alloc_handle(h);
@@ -81,7 +79,6 @@ value win_alloc_handle_or_socket(HANDLE h)
     Descr_kind_val(res) = KIND_SOCKET;
   return res;
 }
-#endif
 
 /* Mapping of Windows error codes to POSIX error codes */
 

otherlibs/win32unix/unixsupport.h

@@ -49,10 +49,12 @@ struct filedescr {
 #define CRT_fd_val(v) (((struct filedescr *) Data_custom_val(v))->crt_fd)
 #define Flags_fd_val(v) (((struct filedescr *) Data_custom_val(v))->flags_fd)
 
-/* extern value win_alloc_handle_or_socket(HANDLE); */
+extern value win_alloc_handle_or_socket(HANDLE);
 extern value win_alloc_handle(HANDLE);
 extern value win_alloc_socket(SOCKET);
 extern int win_CRT_fd_of_filedescr(value handle);
+/* Defined in channels.c */
+extern value win_handle_fd(value);
 
 #define NO_CRT_FD (-1)
 #define Nothing ((value) 0)