From 9ab3a6c3747a9e9a5834f4685e98300137c46d93 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Fri, 3 Oct 2025 00:11:02 -0700 Subject: [PATCH] Finish trashing files --- cl-xdg-trash.asd | 6 ++- mountpoints.lisp | 127 +++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 26 ++++++++-- trash.lisp | 92 ++++++++++++++++++++++++++++++++++ trashinfo.lisp | 60 ++++++++++++++++++++++ 5 files changed, 306 insertions(+), 5 deletions(-) create mode 100644 mountpoints.lisp create mode 100644 trash.lisp diff --git a/cl-xdg-trash.asd b/cl-xdg-trash.asd index 93da4c9..dd9f054 100644 --- a/cl-xdg-trash.asd +++ b/cl-xdg-trash.asd @@ -5,12 +5,14 @@ :maintainer "Alexander Rosenberg " :homepage "https://git.zander.im/Zander671/cl-xdg-trash" :license "GPL3" - :depends-on (#:local-time) + :depends-on (#:local-time #:uiop #:trivial-features #:yason #:cffi) :serial t :components ((:file "package") (:file "url-encode") - (:file "trashinfo")) + (:file "mountpoints") + (:file "trashinfo") + (:file "trash")) :long-description #.(uiop:read-file-string (uiop:subpathname *load-pathname* "README.md"))) diff --git a/mountpoints.lisp b/mountpoints.lisp new file mode 100644 index 0000000..fb77750 --- /dev/null +++ b/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)))))))) diff --git a/package.lisp b/package.lisp index cf097f1..5bffcf7 100644 --- a/package.lisp +++ b/package.lisp @@ -1,19 +1,31 @@ (defpackage :cl-xdg-trash/url-encode (:documentation "URL encoding and decoding functions.") - (:use :cl) + (:use #:cl) (:export #:url-encode #:url-decode #:url-decode-error #:url-decode-error-string #:url-decode-error-index)) +(defpackage :cl-xdg-trash/mountpoints + (:documentation + "Utility function for discovering mount points.") + (:use #:cl) + (:export #:list-mountpoints + #:find-filesystem-root + #:ensure-nonwild-pathname + #:file-or-dir-namestring)) + (defpackage :cl-xdg-trash/trashinfo (:documentation "Parser and utility functions for dealing with .trashinfo files.") - (:use :cl) + (:use #:cl) (:import-from #:cl-xdg-trash/url-encode #:url-encode #:url-decode) + (:import-from #:cl-xdg-trash/mountpoints + #:file-or-dir-namestring + #:ensure-nonwild-pathname) (:export #:trashinfo-format-error #:trashinfo-format-error-message #:trashinfo-format-error-line-numer @@ -27,4 +39,12 @@ #:trashinfo-trashed-file #:parse-trashinfo-from-stream #:parse-trashinfo-file - #:format-trashinfo)) + #:format-trashinfo + #:make-trashinfo-for)) + +(defpackage :cl-xdg-trash + (:documentation + "Common Lisp interface to the XDG trash specification.") + (:use #:cl #:cl-xdg-trash/trashinfo #:cl-xdg-trash/url-encode + #:cl-xdg-trash/mountpoints) + (:export)) diff --git a/trash.lisp b/trash.lisp new file mode 100644 index 0000000..3532e0d --- /dev/null +++ b/trash.lisp @@ -0,0 +1,92 @@ +(in-package :cl-xdg-trash) + +(declaim (ftype (function () (or integer null)) getuid)) +(defun getuid () + "Return the current user's UID, or nil if it cannot be determined." + #+sbcl (sb-posix:getuid) + #-(or sbcl) nil) + +(declaim (ftype (function (&key (:homedir (or pathname string null))) pathname) + xdg-data-home)) +(defun xdg-data-home (&key homedir) + (let ((env (uiop:getenv "XDG_DATA_HOME"))) + (cond + (env (uiop:parse-native-namestring + (pathname env) :ensure-directory t)) + ((not homedir) + (merge-pathnames #P".local/share/" + (user-homedir-pathname))) + ((pathnamep homedir) + (merge-pathnames #P".local/share/" + (uiop:ensure-directory-pathname homedir))) + (t + (merge-pathnames #P".local/share/" + (uiop:parse-native-namestring homedir + :ensure-directory t)))))) + +(declaim (ftype (function (&key (:homedir (or pathname string null))) pathname) + user-home-trash-directory)) +(defun user-home-trash-directory (&key homedir) + (merge-pathnames #P"Trash/" (xdg-data-home :homedir homedir))) + +(declaim (ftype (function ((or string pathname)) list) find-trash-dirs-for-toplevel)) +(defun find-trash-dirs-for-toplevel (toplevel) + "List the trash directories that exist under TOPLEVEL." + (let ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t)) + found) + (let ((dir (merge-pathnames #P".Trash" top-path))) + (when (uiop:directory-exists-p dir) + (push dir found))) + (let ((uid (getuid))) + (when uid + (let ((dir (merge-pathnames (pathname (format nil ".Trash-~D" uid)) + top-path))) + (when (uiop:directory-exists-p dir) + (push dir found))))) + found)) + +(declaim (ftype (function () list) list-toplevel-trash-directories)) +(defun list-toplevel-trash-directories () + "List all known trash directories other than the user's trash directory." + (mapcan 'find-trash-dirs-for-toplevel (list-mountpoints))) + +(declaim (ftype (function () list) list-trash-directories)) +(defun list-trash-directories () + "List all known trash directories." + (cons (user-home-trash-directory) (list-toplevel-trash-directories))) + +(declaim (ftype (function ((or pathname string) &key (:include-self t)) t) + path-in-home-directory-p)) +(defun path-in-home-directory-p (path &key include-self) + "Return non-nil if PATH is in the user's home directory (or is the user's home +directory)." + (let ((path (ensure-nonwild-pathname path :ensure-directory t)) + (home (user-homedir-pathname))) + (or (and include-self (uiop:pathname-equal path home)) + (uiop:subpathp path home)))) + +(declaim (ftype (function ((or pathname string)) pathname) + trash-directory-for-file)) +(defun trash-directory-for-file (path) + "Return the trash directory into which PATH should be trashed." + (let* ((res-path (ensure-nonwild-pathname path)) + (root (find-filesystem-root res-path))) + (or (and (path-in-home-directory-p res-path) + (uiop:pathname-equal (find-filesystem-root (user-homedir-pathname)) + root) + (car (find-trash-dirs-for-toplevel root))) + (user-home-trash-directory)))) + +(declaim (ftype (function ((or pathname string)) t) trash-file)) +(defun trash-file (path) + "Move PATH to the trash. Specifically, move it to the proper trash as +specified by the XDG standard." + (let* ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd))) + (trash-directory (trash-directory-for-file path)) + (trashinfo (make-trashinfo-for trash-directory path)) + (files-dir (ensure-directories-exist (merge-pathnames + #P"files/" trash-directory) + :verbose nil))) + (rename-file path (merge-pathnames + (make-pathname :name (trashinfo-name trashinfo)) + files-dir)))) diff --git a/trashinfo.lisp b/trashinfo.lisp index be50c75..07b04af 100644 --- a/trashinfo.lisp +++ b/trashinfo.lisp @@ -174,6 +174,66 @@ TRASH-DIRECTORY. If SOURCE-FILE is not provided, it will be calculated." (url-encode path :safe-chars '(#\/)) (format-trashinfo-timestamp deletion-date)))) +(declaim (ftype (function (pathname (or string pathname)) stream) + open-trashinfo-for)) +(defun open-trashinfo-for (trash-directory path) + (loop with trash-directory = (ensure-nonwild-pathname trash-directory + :ensure-directory t) + with name = (file-or-dir-namestring path) + with info-dir = (ensure-directories-exist + (merge-pathnames #P"info/" + (uiop:ensure-directory-pathname + trash-directory)) + :verbose nil) + for info-file = (merge-pathnames + (make-pathname + :name (format nil "~A-~D" + name (random most-positive-fixnum)) + :type "trashinfo") + info-dir) + for stream = (open info-file :direction :output + :if-exists nil + :if-does-not-exist :create) + until stream + finally (return stream))) + +(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 (pathname (or pathname string) + &optional local-time:timestamp) + trashinfo) + make-trashinfo-for)) +(defun make-trashinfo-for (trash-directory path &optional (deletion-date + (local-time:now))) + "Generate a new name based off PATH and create a new trashinfo file under +TRASH-DIRECTORY. Return a trashinfo object pointing to this file." + (let* ((path (ensure-nonwild-pathname path)) + (stream (open-trashinfo-for trash-directory path))) + (prog1 + (handler-bind + ((t #'(lambda (e) + (close stream :abort t) + (signal e)))) + (let ((trashinfo + (make-instance 'trashinfo + :path (uiop:native-namestring + (merge-pathnames path (uiop:getcwd))) + :name (remove-suffix + (file-or-dir-namestring + (pathname stream)) + ".trashinfo") + :trash-directory trash-directory + :deletion-date deletion-date))) + (format-trashinfo trashinfo stream) + trashinfo)) + ;; if we exited successfully + (close stream)))) + ;; Local Variables: ;; jinx-local-words: "trashinfo"