diff --git a/srfi/170.scm b/srfi/170.scm index cb15210..ffaa50f 100644 --- a/srfi/170.scm +++ b/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))) diff --git a/srfi/170.sld b/srfi/170.sld index 4f63443..898cead 100644 --- a/srfi/170.sld +++ b/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