Finish trashing files

mountpoints.lisp

@@ -0,0 +1,127 @@
+(in-package :cl-xdg-trash/mountpoints)
+
+(declaim (ftype (function (string) string) unescape-linux-fstab-string))
+(defun unescape-linux-fstab-string (str)
+  "Return a copy of STR with Linux fstab escape sequences processed."
+  (coerce (loop with i = 0
+                while (< i (length str))
+                for char = (aref str i)
+                when (eql char #\\)
+                  collect (code-char (parse-integer str :start (1+ i)
+                                                        :end (+ i 4)
+                                                        :radix 8))
+                  and do (incf i 4)
+                else
+                  collect char
+                  and do (incf i))
+          'string))
+
+(declaim (ftype (function (string) list) parse-linux-fstab-options))
+(defun parse-linux-fstab-options (str)
+  "Parse STR, a comma separated list of mount options, to a list."
+  (mapcar #'unescape-linux-fstab-string (uiop:split-string str :separator '(#\,))))
+
+(declaim (ftype (function (string) list) parse-linux-fstab-line))
+(defun parse-linux-fstab-line (line)
+  (destructuring-bind (source target fstype options &rest rest)
+      (uiop:split-string line :separator '(#\ ))
+    (declare (ignore rest))
+    (list (unescape-linux-fstab-string source)
+          (unescape-linux-fstab-string target)
+          (unescape-linux-fstab-string fstype)
+          (parse-linux-fstab-options options))))
+
+(declaim (ftype (function (&key (:only-real t) (:only-writable t)) list)
+                list-linux-mountpoints))
+(defun list-linux-mountpoints (&key only-real only-writable)
+  "List all mount points on a Linux system. "
+  (with-open-file (in #P"/proc/mounts")
+    (loop for line = (read-line in nil)
+          while line
+          for (source target fstype options) = (parse-linux-fstab-line line)
+          when (and (or (not only-real) (uiop:string-prefix-p "/" source))
+                    (or (not only-writable) (member "rw" options
+                                                    :test #'equal)))
+            collect (if (uiop:string-suffix-p target "/")
+                        target
+                        (format nil "~A/" target)))))
+
+(declaim (ftype (function (&key (:only-real t) (:only-writable t)) list)
+                list-mountpoints))
+(defun list-mountpoints (&key only-real only-writable)
+  "List all mount points on the system. If ONLY-REAL is non-nil attempt to only
+return file systems like ext4, btrfs, zfs, etc. If ONLY-WRITABLE is non-nil, only
+return file-systems that were mounted read-write."
+  #+linux (list-linux-mountpoints :only-real only-real
+                                  :only-writable only-writable)
+  #-(or linux) nil)
+
+(declaim (ftype (function (string) (or integer null)) device-id-for-path))
+(defun device-id-for-path (path)
+  "Return the device id for the device on which PATH resides, or nil if it can't
+be determined."
+  #+sbcl (handler-case
+             (sb-posix:stat-dev (sb-posix:stat path))
+           (sb-posix:syscall-error ()
+             nil))
+  #-(or sbcl) nil)
+
+(declaim (ftype (function ((or pathname string) &key (:ensure-directory t))
+                          pathname)
+                ensure-nonwild-pathname))
+(defun ensure-nonwild-pathname (path &key ensure-directory)
+  "coerce path into a pathname. signal a file-error if it is wild."
+  (if (pathnamep path)
+      (progn
+        (when (wild-pathname-p path)
+          (error 'file-error :pathname path))
+        (if ensure-directory
+            (uiop:ensure-directory-pathname path)
+            path))
+      (uiop:parse-native-namestring path :ensure-directory ensure-directory)))
+
+(declaim (ftype (function ((or string pathname)) string) file-or-dir-namestring))
+(defun file-or-dir-namestring (path)
+  "Return the name of the last component of PATH, be it a file or directory."
+  (if (uiop:pathname-equal path "/")
+      "/"
+      (first (last (pathname-directory
+                    (ensure-nonwild-pathname path :ensure-directory t))))))
+
+(declaim (ftype (function ((or string pathname)) (or pathname null))
+                deepest-existing-path))
+(defun deepest-existing-path (path)
+  "Return the truename of the first parent of PATH that exists. If one of the
+leaning components of PATH exists, but is not a directory, return nil."
+  (let ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd))))
+    (handler-case
+        (and (truename path) path)
+      (file-error ()
+        (loop for cur = (uiop:pathname-parent-directory-pathname
+                         (uiop:ensure-directory-pathname path))
+                then (uiop:pathname-parent-directory-pathname cur)
+              until (probe-file cur)
+              finally (return (when (uiop:directory-exists-p cur)
+                                cur)))))))
+
+(declaim (ftype (function ((or string pathname)) (or pathname null))
+                find-filesystem-root))
+(defun find-filesystem-root (path)
+  "Find the root of the file-system on which PATH resides. If it cannot be
+determined, return nil."
+  (let ((bottom (deepest-existing-path path)))
+    (when bottom
+      (let ((bottom-dev (device-id-for-path (uiop:native-namestring bottom))))
+        (when bottom-dev
+          (loop ;; this will return two directories up for non-directory
+                ;; pathname, but that is OK as a non-directory file is going to
+                ;; be on the same device as its parent directory anyway
+                for prev = nil then cur
+                for cur = (uiop:pathname-parent-directory-pathname bottom)
+                  then (uiop:pathname-parent-directory-pathname cur)
+                for dev = (device-id-for-path (uiop:native-namestring cur))
+                while (and (eql dev bottom-dev))
+                when (uiop:pathname-equal cur prev)
+                  ;; we have reached the root
+                  do (return cur)
+                finally (return (or prev bottom))))))))