diff options
| -rw-r--r-- | guix/build/syscalls.scm | 124 | ||||
| -rw-r--r-- | tests/syscalls.scm | 60 |
2 files changed, 184 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 2def2a108f..624941253a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -68,6 +69,7 @@ mkdtemp! fdatasync pivot-root + scandir* fcntl-flock set-thread-name @@ -819,6 +821,128 @@ system to PUT-OLD." ;;; +;;; Opendir & co. +;;; + +(define-c-struct %struct-dirent-header + sizeof-dirent-header + (lambda (inode offset length type name) + ;; Convert TYPE to symbols like 'stat:type' does. + (let ((type (cond ((= type DT_REG) 'regular) + ((= type DT_LNK) 'symlink) + ((= type DT_DIR) 'directory) + ((= type DT_FIFO) 'fifo) + ((= type DT_CHR) 'char-special) + ((= type DT_BLK) 'block-special) + ((= type DT_SOCK) 'socket) + (else 'unknown)))) + `((type . ,type) + (inode . ,inode)))) + read-dirent-header + write-dirent-header! + (inode int64) + (offset int64) + (length unsigned-short) + (type uint8) + (name uint8)) ;first byte of 'd_name' + +;; Constants for the 'type' field, from <dirent.h>. +(define DT_UNKNOWN 0) +(define DT_FIFO 1) +(define DT_CHR 2) +(define DT_DIR 4) +(define DT_BLK 6) +(define DT_REG 8) +(define DT_LNK 10) +(define DT_SOCK 12) +(define DT_WHT 14) + +(define string->pointer/utf-8 + (cut string->pointer <> "UTF-8")) + +(define pointer->string/utf-8 + (cut pointer->string <> <> "UTF-8")) + +(define opendir* + (let ((proc (syscall->procedure '* "opendir" '(*)))) + (lambda* (name #:optional (string->pointer string->pointer/utf-8)) + (let-values (((ptr err) + (proc (string->pointer name)))) + (if (null-pointer? ptr) + (throw 'system-error "opendir*" + "opendir*: ~A" + (list (strerror err)) + (list err)) + ptr))))) + +(define closedir* + (let ((proc (syscall->procedure int "closedir" '(*)))) + (lambda (directory) + (let-values (((ret err) + (proc directory))) + (unless (zero? ret) + (throw 'system-error "closedir" + "closedir: ~A" (list (strerror err)) + (list err))))))) + +(define readdir* + (let ((proc (syscall->procedure '* "readdir64" '(*)))) + (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) + (let ((ptr (proc directory))) + (and (not (null-pointer? ptr)) + (cons (pointer->string + (make-pointer (+ (pointer-address ptr) + (c-struct-field-offset + %struct-dirent-header name))) + -1) + (read-dirent-header + (pointer->bytevector ptr sizeof-dirent-header)))))))) + +(define* (scandir* name #:optional + (select? (const #t)) + (entry<? (lambda (entry1 entry2) + (match entry1 + ((name1 . _) + (match entry2 + ((name2 . _) + (string<? name1 name2))))))) + #:key + (string->pointer string->pointer/utf-8) + (pointer->string pointer->string/utf-8)) + "This procedure improves on Guile's 'scandir' procedure in several ways: + + 1. Systematically encode decode file names using STRING->POINTER and + POINTER->STRING (UTF-8 by default; this works around a defect in Guile 2.0/2.2 + where 'scandir' decodes file names according to the current locale, which is + not always desirable. + + 2. Each entry that is returned has the form (NAME . PROPERTIES). + PROPERTIES is an alist showing additional properties about the entry, as + found in 'struct dirent'. An entry may look like this: + + (\"foo.scm\" (type . regular) (inode . 123456)) + + Callers must be prepared to deal with the case where 'type' is 'unknown' + since some file systems do not provide that information. + + 3. Raise to 'system-error' when NAME cannot be opened." + (let ((directory (opendir* name string->pointer))) + (dynamic-wind + (const #t) + (lambda () + (let loop ((result '())) + (match (readdir* directory pointer->string) + (#f + (sort result entry<?)) + (entry + (loop (if (select? entry) + (cons entry result) + result)))))) + (lambda () + (closedir* directory))))) + + +;;; ;;; Advisory file locking. ;;; diff --git a/tests/syscalls.scm b/tests/syscalls.scm index e20f0600bc..8c048e6109 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -24,6 +24,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) + #:use-module (system foreign) + #:use-module ((ice-9 ftw) #:select (scandir)) #:use-module (ice-9 match)) ;; Test the (guix build syscalls) module, although there's not much that can @@ -184,6 +186,64 @@ (status:exit-val status)))) (eq? #t result)))))))) +(test-equal "scandir*, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (scandir* "/does/not/exist")) + (lambda args + (system-error-errno args)))) + +(test-equal "scandir*, ASCII file names" + (scandir (dirname (search-path %load-path "guix/base32.scm")) + (const #t) string<?) + (match (scandir* (dirname (search-path %load-path "guix/base32.scm"))) + (((names . properties) ...) + names))) + +(test-equal "scandir*, UTF-8 file names" + '("." ".." "α" "λ") + (call-with-temporary-directory + (lambda (directory) + ;; Wrap 'creat' to make sure that we really pass a UTF-8-encoded file + ;; name to the system call. + (let ((creat (pointer->procedure int + (dynamic-func "creat" (dynamic-link)) + (list '* int)))) + (creat (string->pointer (string-append directory "/α") + "UTF-8") + #o644) + (creat (string->pointer (string-append directory "/λ") + "UTF-8") + #o644) + (let ((locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + ;; Make sure that even in a C locale we get the right result. + (setlocale LC_ALL "C")) + (lambda () + (match (scandir* directory) + (((names . properties) ...) + names))) + (lambda () + (setlocale LC_ALL locale)))))))) + +(test-assert "scandir*, properties" + (let ((directory (dirname (search-path %load-path "guix/base32.scm")))) + (every (lambda (entry name) + (match entry + ((name2 . properties) + (and (string=? name2 name) + (let* ((full (string-append directory "/" name)) + (stat (lstat full)) + (inode (assoc-ref properties 'inode)) + (type (assoc-ref properties 'type))) + (and (= inode (stat:ino stat)) + (or (eq? type 'unknown) + (eq? type (stat:type stat))))))))) + (scandir* directory) + (scandir directory (const #t) string<?)))) + (false-if-exception (delete-file temp-file)) (test-equal "fcntl-flock wait" 42 ; the child's exit status |