From e7f464bac58e1f09de5ceb194c4a30f6d899b29a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 30 May 2017 12:03:54 +0200
Subject: [PATCH] syscalls: Add 'scandir/utf-8'.

* guix/build/syscalls.scm (%struct-dirent-header): New C struct.
(opendir/utf-8, closedir/utf-8, readdir/utf-8, scandir/utf-8): New
procedures.
* tests/syscalls.scm ("scandir/utf-8, ENOENT")
("scandir/utf-8, ASCII file names")
("scandir/utf8, UTF-8 file names"): New tests.
---
 guix/build/syscalls.scm | 73 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/syscalls.scm      | 39 ++++++++++++++++++++++++++
 2 files changed, 112 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 52439afd4..cfb43e93b 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -67,6 +67,7 @@
             mkdtemp!
             fdatasync
             pivot-root
+            scandir/utf-8
             fcntl-flock
 
             set-thread-name
@@ -812,6 +813,78 @@ system to PUT-OLD."
 
 
 ;;;
+;;; Opendir & co.
+;;;
+
+(define-c-struct %struct-dirent-header
+  sizeof-dirent-header
+  list
+  read-dirent-header
+  write-dirent-header!
+  (inode  int64)
+  (offset int64)
+  (length unsigned-short)
+  (type   uint8)
+  (name   uint8))                                 ;first byte of 'd_name'
+
+(define opendir/utf-8
+  (let ((proc (syscall->procedure '* "opendir" '(*))))
+    (lambda (name)
+      (let-values (((ptr err)
+                    (proc (string->pointer name "UTF-8"))))
+        (if (null-pointer? ptr)
+            (throw 'system-error "opendir/utf-8"
+                   "opendir/utf-8: ~A"
+                   (list (strerror err))
+                   (list err))
+            ptr)))))
+
+(define closedir/utf-8
+  (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/utf-8
+  (let ((proc (syscall->procedure '* "readdir64" '(*))))
+    (lambda (directory)
+      (let ((ptr (proc directory)))
+        (and (not (null-pointer? ptr))
+             (pointer->string
+              (make-pointer (+ (pointer-address ptr)
+                               (c-struct-field-offset %struct-dirent-header name)))
+              -1
+              "UTF-8"))))))
+
+(define* (scandir/utf-8 name #:optional
+                        (select? (const #t))
+                        (string<? string<?))
+  "Like 'scandir', but (1) systematically decode file names as UTF-8, and (2)
+raise to 'system-error' when NAME cannot be opened.
+
+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."
+  (let ((directory (opendir/utf-8 name)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (let loop ((result '()))
+          (match (readdir/utf-8 directory)
+            (#f
+             (sort result string<?))
+            (entry
+             (loop (if (select? entry)
+                       (cons entry result)
+                       result))))))
+      (lambda ()
+        (closedir/utf-8 directory)))))
+
+
+;;;
 ;;; Advisory file locking.
 ;;;
 
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index e20f0600b..02062ec9d 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,43 @@
                          (status:exit-val status))))
                (eq? #t result))))))))
 
+(test-equal "scandir/utf-8, ENOENT"
+  ENOENT
+  (catch 'system-error
+    (lambda ()
+      (scandir/utf-8 "/does/not/exist"))
+    (lambda args
+      (system-error-errno args))))
+
+(test-equal "scandir/utf-8, ASCII file names"
+  (scandir (dirname (search-path %load-path "guix/base32.scm")))
+  (scandir/utf-8 (dirname (search-path %load-path "guix/base32.scm"))))
+
+(test-equal "scandir/utf8, 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 ()
+             (scandir/utf-8 directory))
+           (lambda ()
+             (setlocale LC_ALL locale))))))))
+
 (false-if-exception (delete-file temp-file))
 (test-equal "fcntl-flock wait"
   42                                              ; the child's exit status
-- 
2.13.0