[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/02: ice-9 ftw: handle missing getuid and getgid
From: |
Mike Gran |
Subject: |
[Guile-commits] 01/02: ice-9 ftw: handle missing getuid and getgid |
Date: |
Mon, 16 Apr 2018 23:58:11 -0400 (EDT) |
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)