[Guile-commits] 01/02: ice-9 ftw: handle missing getuid and getgid

[Mike Gran]

mike121 pushed a commit to branch wip-mingw-guile-2.2
in repository guile.

commit 5cad80262ae90580ba8076ada9f2a8eb51454005
Author: Michael Gran <address@hidden>
Date:   Mon Apr 16 20:38:38 2018 -0700

    ice-9 ftw: handle missing getuid and getgid
    
    * module/ice-9/ftw.scm (getuid-or-false, getgid-or-false): new macros
      (stat-dir-readable?-proc): don't overwrite arguments
      (ftw, nftw): use new macros
    * test-suite/tests/ftw.test (test-EACCES): don't presume getuid exists
---
 module/ice-9/ftw.scm      | 40 +++++++++++++++++++++++++---------------
 test-suite/tests/ftw.test |  4 ++--
 2 files changed, 27 insertions(+), 17 deletions(-)

diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 7863628..203b546 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -1,6 +1,6 @@
 ;;;; ftw.scm --- file system tree walk
 
-;;;;   Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014, 2016 Free Software 
Foundation, Inc.
+;;;;   Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014, 2016, 2018 Free 
Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -199,6 +199,16 @@
             file-system-tree
             scandir))
 
+(define-macro (getuid-or-false)
+  (if (defined? 'getuid)
+      (getuid)
+      #f))
+
+(define-macro (getgid-or-false)
+  (if (defined? 'getgid)
+      (getgid)
+      #f))
+
 (define (directory-files dir)
   (let ((dir-stream (opendir dir)))
     (let loop ((new (readdir dir-stream))
@@ -253,18 +263,16 @@
                   #f)))))))
 
 (define (stat-dir-readable?-proc uid gid)
-  (let ((uid (getuid))
-        (gid (getgid)))
-    (lambda (s)
-      (let* ((perms (stat:perms s))
-             (perms-bit-set? (lambda (mask)
-                               (not (= 0 (logand mask perms))))))
-        (or (zero? uid)
-            (and (= uid (stat:uid s))
-                 (perms-bit-set? #o400))
-            (and (= gid (stat:gid s))
-                 (perms-bit-set? #o040))
-            (perms-bit-set? #o004))))))
+  (lambda (s)
+    (let* ((perms (stat:perms s))
+           (perms-bit-set? (lambda (mask)
+                             (logtest mask perms))))
+      (or (equal? uid 0)
+          (and (equal? uid (stat:uid s))
+               (perms-bit-set? #o400))
+          (and (equal? gid (stat:gid s))
+               (perms-bit-set? #o040))
+          (perms-bit-set? #o004)))))
 
 (define (stat&flag-proc dir-readable? . control-flags)
   (let* ((directory-flag (if (memq 'depth control-flags)
@@ -305,7 +313,8 @@
   (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
                                         (else 211))))
          (stat&flag (stat&flag-proc
-                     (stat-dir-readable?-proc (getuid) (getgid)))))
+                     (stat-dir-readable?-proc (getuid-or-false)
+                                              (getgid-or-false)))))
     (letrec ((go (lambda (fullname)
                    (call-with-values (lambda () (stat&flag fullname))
                      (lambda (s flag)
@@ -351,7 +360,8 @@
                         (lambda (flag) (eq? flag 'directory-processed))
                         (lambda (flag) (eq? flag 'directory))))
          (stat&flag (apply stat&flag-proc
-                           (stat-dir-readable?-proc (getuid) (getgid))
+                           (stat-dir-readable?-proc (getuid-or-false)
+                                                    (getgid-or-false))
                            (cons 'nftw-style control-flags))))
     (letrec ((go (lambda (fullname base level)
                    (call-with-values (lambda () (stat&flag fullname))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index 7cd88e4..6fd1008 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -1,6 +1,6 @@
 ;;;; ftw.test --- exercise ice-9/ftw.scm      -*- scheme -*-
 ;;;;
-;;;; Copyright 2006, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright 2006, 2011, 2012, 2018 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -217,7 +217,7 @@
   (let ((name (string-append %top-builddir "/test-EACCES")))
     (pass-if-equal "EACCES"
         `((error ,name ,EACCES))
-      (if (zero? (getuid))
+      (if (and (defined? 'getuid) (zero? (getuid)))
           ;; When run as root, this test would fail because root can
           ;; list the contents of #o000 directories.
           (throw 'unresolved)