Allow file ports in ‘readlink’.

* configure.ac: Detect whether ‘readlinkat’ is defined.
* libguile/filesys.c (scm_readlink): Support file ports
  when ‘readlinkat’ exists.
  (scm_init_filesys): Provide ‘chdir-ports’ when it exists.
* doc/ref/posix.texi (File System): Document it.
* test-suite/tests/filesys.test ("readlink"): Test it.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

configure.ac

@@ -516,7 +516,7 @@ AC_CHECK_HEADERS([crt_externs.h])
 #   pipe2 - non-POSIX, found in glibc (GNU/Linux and GNU/Hurd)
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
-  fesetround ftime ftruncate fchown fchmod fchdir			\
+  fesetround ftime ftruncate fchown fchmod fchdir readlinkat		\
   getcwd geteuid getsid							\
   gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod   \
   nice readlink rmdir setegid seteuid                            \

doc/ref/posix.texi

@@ -775,8 +775,13 @@ file it points to.  @var{path} must be a string.
 
 @deffn {Scheme Procedure} readlink path
 @deffnx {C Function} scm_readlink (path)
-Return the value of the symbolic link named by @var{path} (a
+Return the value of the symbolic link named by @var{path} (a string, or
-string), i.e., the file that the link points to.
+a port if supported by the system), i.e., the file that the link points
+to.
+
+To read a symbolic link represented by a port, the symbolic link must
+have been opened with the @code{O_NOFOLLOW} and @code{O_PATH} flags.
+@code{(provided? 'readlink-port)} reports whether ports are supported.
 @end deffn
 
 @findex fchown

libguile/filesys.c

@@ -1032,10 +1032,30 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
 #undef FUNC_NAME
 #endif /* HAVE_SYMLINK */
 
+/* Static helper function for choosing between readlink
+   and readlinkat. */
+static int
+do_readlink (int fd, const char *c_path, char *buf, size_t size)
+{
+#ifdef HAVE_READLINKAT
+  if (fd != -1)
+    return readlinkat (fd, c_path, buf, size);
+#else
+  (void) fd;
+#endif
+  return readlink (c_path, buf, size);
+}
+
 SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
             (SCM path),
             "Return the value of the symbolic link named by @var{path} (a\n"
-	    "string), i.e., the file that the link points to.")
+            "string, or a port if supported by the system),\n"
+            "i.e., the file that the link points to.\n"
+            "To read a symbolic link represented by a port, the symbolic\n"
+            "link must have been opened with the @code{O_NOFOLLOW} and\n"
+            "@code{O_PATH} flags."
+            "@code{(provided? 'readlink-port)} reports whether ports are\n"
+            "supported.")
 #define FUNC_NAME s_scm_readlink
 {
   int rv;
@@ -1043,20 +1063,31 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
   char *buf;
   SCM result;
   char *c_path;
+  int fdes;
 
   scm_dynwind_begin (0);
-
+#ifdef HAVE_READLINKAT
+  if (SCM_OPFPORTP (path))
+    {
+      c_path = "";
+      fdes = SCM_FPORT_FDES (path);
+    }
+  else
+#endif
+    {
+      fdes = -1;
       c_path = scm_to_locale_string (path);
       scm_dynwind_free (c_path);
-
+    }
   buf = scm_malloc (size);
 
-  while ((rv = readlink (c_path, buf, size)) == size)
+  while ((rv = do_readlink (fdes, c_path, buf, size)) == size)
     {
       free (buf);
       size *= 2;
       buf = scm_malloc (size);
     }
+  scm_remember_upto_here_1 (path);
   if (rv == -1)
     {
       int save_errno = errno;
@@ -2073,6 +2104,9 @@ scm_init_filesys ()
 #ifdef HAVE_FCHDIR
   scm_add_feature("chdir-port");
 #endif
+#ifdef HAVE_READLINKAT
+  scm_add_feature("readlink-port");
+#endif
 
 #include "filesys.x"
 }

test-suite/tests/filesys.test

@@ -306,3 +306,64 @@
 
   (pass-if-exception "non-file port" exception:wrong-type-arg
     (chdir (open-input-string ""))))
+
+(with-test-prefix "readlink"
+  (false-if-exception (delete-file (test-symlink)))
+  (false-if-exception (delete-file (test-file)))
+  (call-with-output-file (test-file)
+    (lambda (port)
+      (display "hello" port)))
+  (if (not (false-if-exception
+	    (begin (symlink (test-file) (test-symlink)) #t)))
+      (display "cannot create symlink, some readlink tests skipped\n")
+      (let ()
+        (pass-if-equal "file name of symlink" (test-file)
+          (readlink (test-symlink)))
+
+        (pass-if-equal "port representing a symlink" (test-file)
+          (let ()
+            (unless (and (provided? 'readlink-port)
+                         (defined? 'O_NOFOLLOW)
+                         (defined? 'O_PATH)
+                         (not (= 0 O_NOFOLLOW))
+                         (not (= 0 O_PATH)))
+              (throw 'unsupported))
+            (define port (open (test-symlink) (logior O_NOFOLLOW O_PATH)))
+            (define points-to (false-if-exception (readlink port)))
+            (close-port port)
+            points-to))
+
+        (pass-if-exception "not a port or file name" exception:wrong-type-arg
+          (readlink '(stuff)))))
+
+  (pass-if-equal "port representing a regular file" EINVAL
+    (call-with-input-file (test-file)
+      (lambda (port)
+        (unless (provided? 'readlink-port)
+          (throw 'unsupported))
+        (catch 'system-error
+          (lambda ()
+            (readlink port)
+            (close-port port) ; should be unreachable
+            #f)
+          (lambda args
+            (close-port port)
+            ;; At least Linux 5.10.46 returns ENOENT instead of EINVAL.
+            ;; Possibly surprising, but it is documented in some man
+            ;; pages and it doesn't appear to be an accident:
+            ;; <https://elixir.bootlin.com/linux/v5.10.46/source/fs/stat.c#L419>.
+            (define error (system-error-errno args))
+            (if (= error ENOENT)
+                EINVAL
+                error))))))
+
+  (pass-if-exception "non-file port" exception:wrong-type-arg
+    (readlink (open-input-string "")))
+
+  (pass-if-exception "closed port" exception:wrong-type-arg
+    (let ((port (open-file (test-file) "r")))
+      (close-port port)
+      (readlink port)))
+
+  (false-if-exception (delete-file (test-symlink)))
+  (false-if-exception (delete-file (test-file))))