New filesystem object testing functions.

* lisplib.c (path_test_set_entries, path_test_instantiate):
New static functions.
(dlt_register): Registered new functions to dl_table.

* txr.1: Documented new functions.

* share/txr/stdlib/path-test.tl: New file.

4 files changed, 339 insertions, 0 deletions

diff --git a/ChangeLog b/ChangeLog
index f9c2f55d..65a5775b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,17 @@
 2015-08-05  Kaz Kylheku  <kaz@kylheku.com>
 
+	New filesystem object testing functions.
+
+	* lisplib.c (path_test_set_entries, path_test_instantiate):
+	New static functions.
+	(dlt_register): Registered new functions to dl_table.
+
+	* txr.1: Documented new functions.
+
+	* share/txr/stdlib/path-test.tl: New file.
+
+2015-08-05  Kaz Kylheku  <kaz@kylheku.com>
+
 	Adding support for uid and gid manipulation.
 
 	* configure: Added check for geteuid and related functions.
diff --git a/lisplib.c b/lisplib.c
index 8bb5816e..699d076e 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -140,6 +140,30 @@ static val with_resources_instantiate(val set_fun)
   return nil;
 }
 
+static val path_test_set_entries(val dlt, val fun)
+{
+  val name[] = {
+    lit("path-exists-p"), lit("path-file-p"), lit("path-dir-p"),
+    lit("path-symlink-p"), lit("path-blkdev-p"), lit("path-chrdev-p"),
+    lit("path-sock-p"), lit("path-pipe-p"), lit("path-pipe-p"),
+    lit("path-setgid-p"), lit("path-setuid-p"), lit("path-sticky-p"),
+    lit("path-mine-p"), lit("path-my-group-p"), lit("path-executable-to-me-p"),
+    lit("path-writable-to-me-p"), lit("path-newer"), lit("path-older"),
+    lit("path-same-object"),
+    nil
+  };
+
+  set_dlt_entries(dlt, name, fun);
+  return nil;
+}
+
+static val path_test_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(format(nil, lit("~a/path-test.tl"), stdlib_path, nao));
+  return nil;
+}
+
 val dlt_register(val dlt,
                  val (*instantiate)(val),
                  val (*set_entries)(val, val))
@@ -156,6 +180,7 @@ void lisplib_init(void)
   dlt_register(dl_table, ifa_instantiate, ifa_set_entries);
   dlt_register(dl_table, txr_case_instantiate, txr_case_set_entries);
   dlt_register(dl_table, with_resources_instantiate, with_resources_set_entries);
+  dlt_register(dl_table, path_test_instantiate, path_test_set_entries);
 }
 
 val lisplib_try_load(val sym)
diff --git a/share/txr/stdlib/path-test.tl b/share/txr/stdlib/path-test.tl
new file mode 100644
index 00000000..1ca8d940
--- /dev/null
+++ b/share/txr/stdlib/path-test.tl
@@ -0,0 +1,98 @@
+(defun sys:do-path-test (statfun path testfun)
+  [testfun (if (stringp path) (ignerr [statfun path]) path)])
+
+(defmacro sys:path-test ((var statfun path) . body)
+  ^[sys:do-path-test ,statfun ,path
+     (lambda (,var) (when ,var ,*body))])
+
+(defun sys:path-test-mode (statfun path mask)
+  (sys:path-test (s statfun path)
+    (let ((m (prop s :mode)))
+      (if (plusp (logand m mask)) t))))
+
+(defun path-exists-p (path)
+  (sys:path-test (s stat path) t))
+
+(defun path-file-p (path)
+  [sys:path-test-mode stat path s-ifreg])
+
+(defun path-dir-p (path)
+  [sys:path-test-mode stat path s-ifdir])
+
+(defun path-symlink-p (path)
+  [sys:path-test-mode lstat path s-iflnk])
+
+(defun path-blkdev-p (path)
+  [sys:path-test-mode stat path s-ifblk])
+
+(defun path-chrdev-p (path)
+  [sys:path-test-mode stat path s-ifchr])
+
+(defun path-sock-p (path)
+  [sys:path-test-mode stat path s-ifsock])
+
+(defun path-pipe-p (path)
+  [sys:path-test-mode stat path s-ififo])
+
+(defun path-setgid-p (path)
+  [sys:path-test-mode stat path s-isgid])
+
+(defun path-setuid-p (path)
+  [sys:path-test-mode stat path s-isuid])
+
+(defun path-sticky-p (path)
+  [sys:path-test-mode stat path s-isvtx])
+
+(defun path-mine-p (path)
+  (sys:path-test (s stat path)
+    (let ((u (prop s :uid)))
+      (= u (geteuid)))))
+
+(defun path-my-group-p (path)
+  (sys:path-test (s stat path)
+    (let ((g (prop s :gid)))
+      (or (= g (getegid))
+          (find g (getgroups))))))
+
+(defun sys:path-access (path umask gmask omask)
+  (sys:path-test (s stat path)
+    (let ((m (prop s :mode))
+          (euid (geteuid)))
+      (cond
+        ((zerop euid) (or (zerop (logior umask s-ixusr))
+                          (plusp (logand m (logior umask gmask omask)))))
+        ((= euid (prop s :uid)) (plusp (logand m umask)))
+        ((let ((g (prop s :gid)))
+           (or (= g (getegid))
+               (find g (getgroups))))
+         (plusp (logand m gmask)))
+        (t (plusp (logand m omask)))))))
+
+(defun path-executable-to-me-p (path)
+  (sys:path-access path s-ixusr s-ixgrp s-ixoth))
+
+(defun path-writable-to-me-p (path)
+  (sys:path-access path s-iwusr s-iwgrp s-iwoth))
+
+(defmacro sys:path-examine ((var statfun path) . body)
+  ^[sys:do-path-test ,statfun ,path
+     (lambda (,var) ,*body)])
+
+(defun path-newer (path-0 path-1)
+  (sys:path-examine (s0 stat path-0)
+    (sys:path-examine (s1 stat path-1)
+      (and s0 (or (not s1)
+                  (> (prop s0 :mtime)
+                     (prop s1 :mtime)))))))
+
+(defun path-older (path-0 path-1)
+  (path-newer path-1 path-0))
+
+(defun path-same-object (path-0 path-1)
+  (sys:path-examine (s0 stat path-0)
+    (sys:path-examine (s1 stat path-1)
+      (and s0 s1
+           (eql (prop s0 :dev)
+                (prop s1 :dev))
+           (eql (prop s0 :ino)
+                (prop s1 :ino))))))
diff --git a/txr.1 b/txr.1
index 4dd6a704..93604834 100644
--- a/txr.1
+++ b/txr.1
@@ -29638,6 +29638,210 @@ function reads the contents of that symbolic link and returns it
 as a string.  Otherwise, it fails by throwing an exception of type
 .codn file-error .
 
+.SS* Unix Filesystem Object Existence, Type and Access Tests
+
+The following functions all accept, as the
+.meta path
+argument, either a character string, or a list object returned by the
+.code stat
+or
+.code lstat
+functions.
+
+If the
+.meta path
+argument is a string, then
+.code stat
+is used to retrieve information about it, except in the case of
+the
+.code path-symlink-p
+function, which uses
+.codn lstat .
+The subsequent test is then based on the result of this call.
+
+If the
+.meta path
+argument is the result of a
+.code stat
+or
+.code lstat
+call, then the testing is based on that object.
+
+.coNP Function @ path-exists-p
+.synb
+.mets (path-exists-p << path )
+.syne
+.desc
+The
+.code path-exists-p
+function returns
+.code t
+if
+.meta path
+is a string which resolves to a filesystem object.
+Otherwise it returns
+.codn nil .
+If the
+.meta path
+names a dangling symbolic link, it is considered nonexistent.
+
+If
+.meta path
+is an object returned by
+.code stat
+or
+.codn lstat ,
+.code path-exists-p
+unconditionally returns
+.codn t .
+
+.coNP Functions @, path-file-p @, path-dir-p @, path-symlink-p @, path-blkdev-p @, path-chrdev-p @ path-sock-p and @ path-pipe-p
+.synb
+.mets (path-file-p << path )
+.mets (path-dir-p << path )
+.mets (path-symlink-p << path )
+.mets (path-blkdev-p << path )
+.mets (path-chrdev-p << path )
+.mets (path-sock-p << path )
+.mets (path-pipe-p << path )
+.syne
+.desc
+.code path-file-p
+tests whether
+.meta path
+exists and is a regular file.
+
+.code path-dir-p
+tests whether
+.meta path
+exists and is a directory.
+
+.code path-symlink-p
+tests whether
+.meta path
+exists and is a symbolic link.
+
+Similarly,
+.code path-blkdev-p
+tests for a block device,
+.code path-chrdev-p
+for a character device,
+.code path-sock-p
+for a socket and
+.code path-pipe-p
+for a named pipe.
+
+.coNP Functions @, path-setgid-p @ path-setuid-p and @ path-sticky-p
+.synb
+.mets (path-setgid-p << path )
+.mets (path-setuid-p << path )
+.mets (path-sticky-p << path )
+.syne
+.desc
+
+.code path-setgid-p
+tests whether
+.meta path
+exists and has the set-group-ID permission set.
+
+.code path-setuid-p
+tests whether
+.meta path
+exists and has the set-user-ID permission set.
+
+.code path-sticky-p
+tests whether
+.meta path
+exists and has the "sticky" permission bit set.
+
+.coNP Functions @ path-mine-p and @ path-my-group-p
+.synb
+.mets (path-mine-p << path )
+.mets (path-my-group-p << path )
+.syne
+.desc
+.code path-mine-p
+tests whether
+.meta path
+exists, and is effectively owned by the calling process; that is,
+has a user ID equal to the effective user ID of the process.
+
+.code path-my-group-p
+tests whether
+.meta path
+exists, and is effectively owned by a group to which the calling process
+belongs. This means that the group owner is either the same as the
+effective group ID of the calling process, or else is among the
+supplementary group IDs of the calling process.
+
+.coNP Functions @ path-executable-to-me-p and @ path-writable-to-me-p
+.synb
+.mets (path-executable-to-me-p << path )
+.mets (path-writable-to-me-p << path )
+.syne
+.desc
+.code path-executable-to-me-p
+tests whether the calling process can execute the
+object named by
+.metn path .
+This test is
+carried out using the effective user ID.
+
+.code path-writable-to-me-p
+tests whether the calling process can write the
+object named by
+.metn path .
+This test is
+carried out using the effective user ID.
+
+These tests may not be perfectly accurate, since they are based strictly
+on portable information available via
+.codn stat ,
+ignoring any special permissions which may exist such as operating system
+and file system specific extended attributes (for example, file immutability
+connected to a "secure level" and such).
+
+.coNP Functions @ path-newer and @ path-older
+.synb
+.mets (path-newer < left-path << right-path )
+.mets (path-older < left-path << right-path )
+.syne
+.desc
+The
+.code path-newer
+function compares two paths or stat results by modification time.
+It returns
+.code t
+if
+.meta left-path
+exists, and either
+.meta right-path
+does not exist, or has a modification time stamp in the past
+relative to
+.metn left-path .
+
+The
+.code path-older
+function is equivalent to
+.code path-newer
+with the arguments reversed.
+
+.coNP Functions @ path-same-object
+.synb
+.mets (path-same-object < left-path << right-path )
+.syne
+.desc
+The
+.code path-same-object
+function returns
+.code t
+if
+.meta left-path
+and
+.meta right-path
+resolve to the same filesystem object: the same inode number on the same
+device.
+
 .SS* Unix Credentials
 
 .coNP Functions @, getuid @, geteuid @ getgid and @ getegid