Add ~follow option to Unix.link (#1061)

This allows hardlinking symlinks.

Changes

@@ -41,6 +41,11 @@ Working version
 
 ### Other libraries:
 
+- GPR#1061: Add ?follow parameter to Unix.link. This allows hardlinking
+  symlinks.
+  (Christopher Zimmermann, review by Xavier Leroy, Damien Doligez, David
+   Allsopp, David Sheets)
+
 ### Compiler user-interface and warnings:
 
 - MPR#7116, GPR#1430: new -config-var option

otherlibs/threads/unix.ml

@@ -295,7 +295,7 @@ external fstat : file_descr -> stats = "unix_fstat"
 external isatty : file_descr -> bool = "unix_isatty"
 external unlink : string -> unit = "unix_unlink"
 external rename : string -> string -> unit = "unix_rename"
-external link : string -> string -> unit = "unix_link"
+external link : ?follow:bool -> string -> string -> unit = "unix_link"
 
 module LargeFile =
   struct

otherlibs/unix/link.c

@@ -18,9 +18,12 @@
 #include <caml/signals.h>
 #include "unixsupport.h"
 
-CAMLprim value unix_link(value path1, value path2)
+#include <fcntl.h>
+#include <unistd.h>
+
+CAMLprim value unix_link(value follow, value path1, value path2)
 {
-  CAMLparam2(path1, path2);
+  CAMLparam3(follow, path1, path2);
   char * p1;
   char * p2;
   int ret;
@@ -29,7 +32,19 @@ CAMLprim value unix_link(value path1, value path2)
   p1 = caml_stat_strdup(String_val(path1));
   p2 = caml_stat_strdup(String_val(path2));
   caml_enter_blocking_section();
-  ret = link(p1, p2);
+  if (follow == Val_int(0) /* None */)
+    ret = link(p1, p2);
+  else { /* Some bool */
+# if _XOPEN_VERSION >= 700 || _POSIX_VERSION >= 200809L || defined (_ATFILE_SOURCE)
+    int flags =
+      Is_block(follow) && Bool_val(Field(follow, 0)) /* Some true */
+      ? AT_SYMLINK_FOLLOW
+      : 0;
+    ret = linkat(AT_FDCWD, p1, AT_FDCWD, p2, flags);
+# else
+    ret = -1; errno = ENOSYS;
+# endif
+  }
   caml_leave_blocking_section();
   caml_stat_free(p1);
   caml_stat_free(p2);

otherlibs/unix/unix.ml

@@ -380,7 +380,7 @@ external fstat : file_descr -> stats = "unix_fstat"
 external isatty : file_descr -> bool = "unix_isatty"
 external unlink : string -> unit = "unix_unlink"
 external rename : string -> string -> unit = "unix_rename"
-external link : string -> string -> unit = "unix_link"
+external link : ?follow:bool -> string -> string -> unit = "unix_link"
 
 module LargeFile =
   struct

otherlibs/unix/unix.mli

@@ -564,9 +564,18 @@ val rename : string -> string -> unit
     owner, etc) of [new] can either be preserved or be replaced by
     those of [old].  *)
 
-val link : string -> string -> unit
-(** [link source dest] creates a hard link named [dest] to the file
-   named [source]. *)
+val link :  ?follow:bool -> string -> string -> unit
+(** [link ?follow source dest] creates a hard link named [dest] to the file
+   named [source].
+
+   @param follow indicates whether a [source] symlink is followed or a
+   hardlink to [source] itself will be created. On {e Unix} systems this is
+   done using the [linkat(2)] function. If [?follow] is not provided, then the
+   [link(2)] function is used whose behaviour is OS-dependent, but more widely
+   available.
+
+   @raise ENOSYS On {e Unix} if [~follow:_] is requested, but linkat is unavailable.
+   @raise ENOSYS On {e Windows} if [~follow:false] is requested. *)
 
 
 (** {1 File permissions and ownership} *)

otherlibs/unix/unixLabels.mli

@@ -492,9 +492,18 @@ val unlink : string -> unit
 val rename : src:string -> dst:string -> unit
 (** [rename old new] changes the name of a file from [old] to [new]. *)
 
-val link : src:string -> dst:string -> unit
-(** [link source dest] creates a hard link named [dest] to the file
-   named [source]. *)
+val link : ?follow:bool -> src:string -> dst:string -> unit
+(** [link ?follow source dest] creates a hard link named [dest] to the file
+   named [source].
+
+   @param follow indicates whether a [source] symlink is followed or a
+   hardlink to [source] itself will be created. On {e Unix} systems this is
+   done using the [linkat(2)] function. If [?follow] is not provided, then the
+   [link(2)] function is used whose behaviour is OS-dependent, but more widely
+   available.
+
+   @raise ENOSYS On {e Unix} if [~follow:_] is requested, but linkat is unavailable.
+   @raise ENOSYS On {e Windows} if [~follow:false] is requested. *)
 
 
 (** {1 File permissions and ownership} *)

otherlibs/win32unix/link.c

@@ -20,6 +20,7 @@
 #include <caml/memory.h>
 #include <caml/osdeps.h>
 #include "unixsupport.h"
+#include <errno.h>
 #include <windows.h>
 
 typedef
@@ -29,12 +30,16 @@ BOOL (WINAPI *tCreateHardLink)(
   LPSECURITY_ATTRIBUTES lpSecurityAttributes
 );
 
-CAMLprim value unix_link(value path1, value path2)
+CAMLprim value unix_link(value follow, value path1, value path2)
 {
   HMODULE hModKernel32;
   tCreateHardLink pCreateHardLink;
   BOOL result;
   wchar_t * wpath1, * wpath2;
+  if (Is_block(follow) && !Bool_val(Field(follow, 0))) { /* Some false */
+    errno = ENOSYS;
+    uerror("link", path2);
+  }
   hModKernel32 = GetModuleHandle(L"KERNEL32.DLL");
   pCreateHardLink =
     (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkW");

otherlibs/win32unix/unix.ml

@@ -265,7 +265,7 @@ external isatty : file_descr -> bool = "unix_isatty"
 
 external unlink : string -> unit = "unix_unlink"
 external rename : string -> string -> unit = "unix_rename"
-external link : string -> string -> unit = "unix_link"
+external link : ?follow:bool -> string -> string -> unit = "unix_link"
 
 (* Operations on large files *)