Hi,
I recently noticed that directory* follows symlinks on ECL,
whereas it would be desirable if it didn't. ECLs directory*
function follows symlinks by default, but can be instructed not
to.
Please see below for the tweak and a suggested test case, which I
based on test-symlink-loop.script.
Thank you,
Moritz Petersen
>From d93a43fdfd5871aef285b76d60781048a42d9949 Mon Sep 17 00:00:00 2001
From: Moritz Petersen <moritz.peter...@freenet.de>
Date: Fri, 9 Oct 2020 19:46:49 +0200
Subject: [PATCH] Ask ECL not to follow symlinks in #'directory
ECLs implementation of directory defaults to resolving symlinks, but can be
instructed to do otherwise by passing a keyword argument.
Tweak directory* function and add general test case based on
test-symlink-loop.script
---
...est-directory-no-symlink-resolution.script | 28 +++++++++++++++++++
uiop/filesystem.lisp | 1 +
2 files changed, 29 insertions(+)
create mode 100644 test/test-directory-no-symlink-resolution.script
diff --git a/test/test-directory-no-symlink-resolution.script b/test/test-directory-no-symlink-resolution.script
new file mode 100644
index 000000000000..4661f95413e5
--- /dev/null
+++ b/test/test-directory-no-symlink-resolution.script
@@ -0,0 +1,28 @@
+;;; -*- Lisp -*-
+
+;;; Make sure that directory* (and, by extension, directory-files)
+;;; doesn't follow symlinks
+
+(in-package :asdf-test)
+
+;; since symlinks only somewhat exist on Windows, we don't test there.
+(when (uiop:os-windows-p)
+ (exit-lisp 0))
+
+(let ((scratch-dir (namestring (make-sub-pathname :directory '(:relative "symlink-scratch")
+ :defaults *test-directory*))))
+ (unwind-protect
+ (progn
+ ;; create target file and symlink
+ (uiop:run-program (format nil "mkdir ~a" scratch-dir))
+ (uiop:run-program (format nil "mkdir ~a/subdir" scratch-dir))
+ (uiop:run-program (format nil "touch ~a/subdir/target" scratch-dir))
+ (uiop:run-program (format nil "ln -s ~a/subdir/target ~a/link"
+ scratch-dir scratch-dir))
+ (DBG "Ensuring directory-files doesn't folllow symlinks.")
+ (assert-equal (merge-pathnames (make-pathname :name "link")
+ scratch-dir)
+ (car (uiop:directory-files scratch-dir))))
+ ;; clean up
+ (DBG "Cleaning up")
+ (uiop:delete-directory-tree scratch-dir :validate (lambda (x) (subpathp x *test-directory*)))))
diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp
index b0c184538963..bd1c4e768200 100644
--- a/uiop/filesystem.lisp
+++ b/uiop/filesystem.lisp
@@ -172,6 +172,7 @@ Try to override the defaults to not resolving symlinks, if implementation allows
#+(or clozure digitool) '(:follow-links nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmucl scl) '(:follow-links nil :truenamep nil)
+ #+ecl '(:resolve-symlinks nil)
#+lispworks '(:link-transparency nil)
#+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
'(:resolve-symlinks nil))))))
--
2.28.0
