Add read-symlink to SRFI-170

srfi/170.scm

@@ -15,6 +15,7 @@
 (define-c-procedure c-perror libc 'perror 'void '(pointer))
 (define-c-procedure c-mkdir libc 'mkdir 'int '(pointer int))
 (define-c-procedure c-mkfifo libc 'mkfifo 'int '(pointer int))
+(define-c-procedure c-readlink libc 'readlink 'int '(pointer pointer int))
 (define-c-procedure c-rmdir libc 'rmdir 'int '(pointer))
 (define-c-procedure c-stat libc 'stat 'int '(pointer pointer))
 (define-c-procedure c-lstat libc 'stat 'int '(pointer pointer))
@@ -175,6 +176,29 @@
   (c-slink (string->c-bytevector old-fname)
            (string->c-bytevector new-fname)))
 
+(define (internal-read-symlink fname buffer-length)
+  (let* ((path-pointer (string->c-bytevector fname))
+         (buffer (make-c-bytevector buffer-length))
+         (result (c-readlink path-pointer buffer (- buffer-length 1)))
+         (error-message "read-symlink error")
+         (error-pointer (string->c-bytevector error-message)))
+    (cond ((< result 0)
+           (c-perror error-pointer)
+           (c-bytevector-free error-pointer)
+           (error error-message))
+          ((> result buffer-length)
+           (c-bytevector-free path-pointer)
+           (c-bytevector-free buffer)
+           (internal-read-symlink fname (+ buffer-length buffer-length)))
+          (else
+            (c-bytevector-set! buffer 'u8 result null-byte)
+            (let ((name (c-bytevector->string buffer)))
+              (c-bytevector-free path-pointer)
+              (c-bytevector-free buffer)
+              name)))))
+
+(define (read-symlink fname) (internal-read-symlink fname 128))
+
 (define (rename-file old-fname new-fname)
   (c-rename (string->c-bytevector old-fname)
             (string->c-bytevector new-fname)))

srfi/170.sld

@@ -15,7 +15,7 @@
           create-fifo
           create-hard-link
           create-symlink
-          ;read-symlink
+          read-symlink
           rename-file
           delete-directory
           set-file-owner