From b074efb9c179238f7772ba7ea413afc5cb3133ba Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 4 May 2016 06:58:35 -0700
Subject: Somew new path access testing functions.

* lisplib.c (path_test_set_entries): New elements in the list
for path-readable-to-me-p, path-read-writable-to-me-p, and
path-strictly-private-to-me-p.

* share/txr/stdlib/path-test.pl (sys:path-access): Test
bitwise combinations of permissions, so read+write
can be tested in one call.
(path-readable-to-me-p, path-read-writable-to-me-p,
path-strictly-private-to-me-p): New functions.

* txr.1: Documented.
---
 share/txr/stdlib/path-test.tl | 29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

(limited to 'share')

diff --git a/share/txr/stdlib/path-test.tl b/share/txr/stdlib/path-test.tl
index cb2a1c48..d10fa88e 100644
--- a/share/txr/stdlib/path-test.tl
+++ b/share/txr/stdlib/path-test.tl
@@ -78,6 +78,8 @@
           (find g (getgroups))))))
 
 ;; umask, gmask and omask must test identical permissions
+;; multiple permissions may be tested, but not a combination
+;; of x with any other permission.
 (defun sys:path-access (path umask gmask omask)
   (sys:path-test (s stat path)
     (let ((m s.mode)
@@ -85,12 +87,12 @@
       (cond
         ((zerop euid) (or (zerop (logand umask s-ixusr))
                           (plusp (logand m (logior umask gmask omask)))))
-        ((= euid s.uid) (plusp (logand m umask)))
+        ((= euid s.uid) (= umask (logand m umask)))
         ((let ((g s.gid))
            (or (= g (getegid))
                (find g (getgroups))))
-         (plusp (logand m gmask)))
-        (t (plusp (logand m omask)))))))
+         (= gmask (logand m gmask)))
+        (t (= omask (logand m omask)))))))
 
 (defun path-executable-to-me-p (path)
   (sys:path-access path s-ixusr s-ixgrp s-ixoth))
@@ -98,6 +100,15 @@
 (defun path-writable-to-me-p (path)
   (sys:path-access path s-iwusr s-iwgrp s-iwoth))
 
+(defun path-readable-to-me-p (path)
+  (sys:path-access path s-irusr s-irgrp s-iroth))
+
+(defun path-read-writable-to-me-p (path)
+  (sys:path-access path
+                   (logior s-irusr s-iwusr)
+                   (logior s-irgrp s-iwgrp)
+                   (logior s-iroth s-iwoth)))
+
 (defun path-private-to-me-p (path)
   (sys:path-test (s stat path)
     (let ((m s.mode)
@@ -110,6 +121,18 @@
                  (and (not (rest g.mem))
                       (equal (getpwuid euid).name (first g.mem)))))))))
 
+(defun path-strictly-private-to-me-p (path)
+  (sys:path-test (s stat path)
+    (let ((m s.mode)
+          (euid (geteuid)))
+      (mlet ((g (getgrgid s.gid)))
+        (and (eql euid s.uid)
+             (zerop (logand m (logior s-iroth s-iwoth)))
+             (or (zerop (logand m (logior s-iroth s-iwgrp)))
+                 (null g.mem)
+                 (and (not (rest g.mem))
+                      (equal (getpwuid euid).name (first g.mem)))))))))
+
 (defmacro sys:path-examine ((var statfun path) . body)
   ^[sys:do-path-test ,statfun ,path
      (lambda (,var) ,*body)])
-- 
cgit v1.2.3