1.0.2.24: Support readlink in SB-POSIX

        * Thanks to Richard M Kreuter

diff --git a/NEWS b/NEWS
index 34146fb..35526eb 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,8 @@ changes in sbcl-1.0.3 relative to sbcl-1.0.2:
   * bug fix: use "gtar" as the asdf-install *TAR-PROGRAM* on NetBSD
     (thanks to Jon Buller)
   * improvement: faster compilation times for complex functions
+  * improvement: added readlink support to SB-POSIX (thanks to Richard
+    M Kreuter)
 
 changes in sbcl-1.0.2 relative to sbcl-1.0.1:
   * improvement: experimental support for mach exception handling on

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 779759a..517f71f 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -246,7 +246,30 @@
   (define-call "setpgid" int minusp (pid pid-t) (pgid pid-t))
   (define-call "setpgrp" int minusp))
 
-;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
+#-win32
+(progn
+  (export 'readlink :sb-posix)
+  (defun readlink (pathspec)
+    (flet ((%readlink (path buf length)
+             (alien-funcall
+              (extern-alien "readlink" (function int c-string (* t) int))
+              path buf length)))
+      (loop for size = 128 then (* 2 size)
+            for buf = (make-alien c-string size)
+            do (unwind-protect
+                    (let ((count (%readlink (filename pathspec) buf size)))
+                      (cond ((minusp count)
+                             (syscall-error))
+                            ((< 0 count size)
+                             (setf (sb-sys:sap-ref-8 (sb-alien:alien-sap buf)
+                                                     count)
+                                   0)
+                             (return
+                               (sb-alien::c-string-to-string
+                                (sb-alien:alien-sap buf)
+                                (sb-impl::default-external-format)
+                                'character)))))
+                 (free-alien buf))))))
 
 #-win32
 (progn
@@ -581,4 +604,3 @@ than C's printf) with format string FORMAT and arguments ARGS."
                             priority "%s" message)))
       (syslog1 priority (apply #'format nil format args))))
   (define-call "closelog" void never-fails))
-

diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp
index 78b4754..9de504b 100644 (file)
--- a/contrib/sb-posix/posix-tests.lisp
+++ b/contrib/sb-posix/posix-tests.lisp
@@ -521,6 +521,122 @@
         (list (= (sb-posix:stat-atime stat) atime)
               (= (sb-posix:stat-mtime stat) mtime))))
   (t t))
-
-
-
+\f
+;; readlink tests.
+#-win32
+(progn
+  (deftest readlink.1
+      (let ((link-pathname (make-pathname :name "readlink.1"
+                                          :defaults *test-directory*)))
+        (sb-posix:symlink "/" link-pathname)
+        (unwind-protect
+             (sb-posix:readlink link-pathname)
+          (ignore-errors (sb-posix:unlink link-pathname))))
+    "/")
+
+  ;; Same thing, but with a very long link target (which doesn't have
+  ;; to exist).  This tests the array adjustment in the wrapper,
+  ;; provided that the target's length is long enough.
+  (deftest readlink.2
+      (let ((target-pathname (make-pathname
+                              :name (make-string 255 :initial-element #\a)
+                              :directory '(:absolute)))
+            (link-pathname (make-pathname :name "readlink.2"
+                                          :defaults *test-directory*)))
+        (sb-posix:symlink target-pathname link-pathname)
+        (unwind-protect
+             (sb-posix:readlink link-pathname)
+          (ignore-errors (sb-posix:unlink link-pathname))))
+    #.(concatenate 'string "/" (make-string 255 :initial-element #\a)))
+
+  ;; The error tests are in the order of exposition from SUSv3.
+  (deftest readlink.error.1
+      (let* ((subdir-pathname (merge-pathnames
+                               (make-pathname
+                                :directory '(:relative "readlink.error.1"))
+                               *test-directory*))
+             (link-pathname (make-pathname :name "readlink.error.1"
+                                           :defaults subdir-pathname)))
+        (sb-posix:mkdir subdir-pathname #o777)
+        (sb-posix:symlink "/" link-pathname)
+        (sb-posix:chmod subdir-pathname 0)
+        (unwind-protect
+             (handler-case (sb-posix:readlink link-pathname)
+               (sb-posix:syscall-error (c)
+                 (sb-posix:syscall-errno c)))
+          (ignore-errors
+            (sb-posix:chmod subdir-pathname #o777)
+            (sb-posix:unlink link-pathname)
+            (sb-posix:rmdir subdir-pathname))))
+    #.sb-posix:eacces)
+  (deftest readlink.error.2
+      (let* ((non-link-pathname (make-pathname :name "readlink.error.2"
+                                               :defaults *test-directory*))
+             (fd (sb-posix:open non-link-pathname sb-posix::o-creat)))
+        (unwind-protect
+             (handler-case (sb-posix:readlink non-link-pathname)
+               (sb-posix:syscall-error (c)
+                 (sb-posix:syscall-errno c)))
+          (ignore-errors
+            (sb-posix:close fd)
+            (sb-posix:unlink non-link-pathname))))
+    #.sb-posix:einval)
+  ;; Skipping EIO, ELOOP
+  (deftest readlink.error.3
+      (let* ((link-pathname (make-pathname :name "readlink.error.3"
+                                           :defaults *test-directory*))
+             (bogus-pathname (merge-pathnames
+                              (make-pathname
+                               :name "bogus"
+                               :directory '(:relative "readlink.error.3"))
+                               *test-directory*)))
+        (sb-posix:symlink link-pathname link-pathname)
+        (unwind-protect
+             (handler-case (sb-posix:readlink bogus-pathname)
+               (sb-posix:syscall-error (c)
+                 (sb-posix:syscall-errno c)))
+          (ignore-errors (sb-posix:unlink link-pathname))))
+    #.sb-posix:eloop)
+  ;; Note: PATH_MAX and NAME_MAX need not be defined, and may vary, so
+  ;; failure of this test is not too meaningful.
+  (deftest readlink.error.4
+      (let ((pathname
+             (make-pathname :name (make-string 257 ;NAME_MAX plus some, maybe
+                                               :initial-element #\a))))
+        (handler-case (sb-posix:readlink pathname)
+          (sb-posix:syscall-error (c)
+            (sb-posix:syscall-errno c))))
+    #.sb-posix:enametoolong)
+  (deftest readlink.error.5
+      (let ((string (format nil "~v{/A~}" 2049 ;PATH_MAX/2 plus some, maybe
+                                          '(x))))
+        (handler-case (sb-posix:readlink string)
+          (sb-posix:syscall-error (c)
+            (sb-posix:syscall-errno c))))
+    #.sb-posix:enametoolong)
+    (deftest readlink.error.6
+      (let ((no-such-pathname (make-pathname :name "readlink.error.6"
+                                             :defaults *test-directory*)))
+        (handler-case (sb-posix:readlink no-such-pathname)
+          (sb-posix:syscall-error (c)
+            (sb-posix:syscall-errno c))))
+    #.sb-posix:enoent)
+  (deftest readlink.error.7
+      (let* ((non-link-pathname (make-pathname :name "readlink.error.7"
+                                               :defaults *test-directory*))
+             (impossible-pathname (merge-pathnames
+                                   (make-pathname
+                                    :directory
+                                    '(:relative "readlink.error.7")
+                                    :name "readlink.error.7")
+                                   *test-directory*))
+             (fd (sb-posix:open non-link-pathname sb-posix::o-creat)))
+        (unwind-protect
+             (handler-case (sb-posix:readlink impossible-pathname)
+               (sb-posix:syscall-error (c)
+                 (sb-posix:syscall-errno c)))
+          (ignore-errors
+            (sb-posix:close fd)
+            (sb-posix:unlink non-link-pathname))))
+    #.sb-posix:enotdir)
+  )

diff --git a/version.lisp-expr b/version.lisp-expr
index e515900..0331e9f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.2.23"
+"1.0.2.24"