134 lines
6.0 KiB
Common Lisp
134 lines
6.0 KiB
Common Lisp
(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."
|
|
(handler-case
|
|
(osicat-posix:stat-dev (osicat-posix:stat path))
|
|
(osicat-posix:posix-error ()
|
|
nil)))
|
|
|
|
(declaim (ftype (function (string string) string) remove-suffix))
|
|
(defun remove-suffix (string suffix)
|
|
"Return STRING without SIFFIX."
|
|
(if (uiop:string-suffix-p string suffix)
|
|
(subseq string 0 (- (length string) (length suffix)))
|
|
string))
|
|
|
|
(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 "/")
|
|
"/"
|
|
(let ((unix-path (remove-suffix (uiop:unix-namestring path) "/")))
|
|
(first (last (uiop:split-string unix-path :max 2 :separator '(#\/)))))))
|
|
|
|
(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))))))))
|