394 lines
18 KiB
Common Lisp
394 lines
18 KiB
Common Lisp
(in-package :cl-xdg-trash)
|
|
|
|
(define-condition trash-error (error)
|
|
((trash-directory :accessor trash-error-trash-directory
|
|
:type (or pathname string)
|
|
:initarg :trash-directory
|
|
:documentation "The trash directory of the operation."))
|
|
(:report (lambda (condition stream)
|
|
(format stream "Error operating on trash directory: ~S"
|
|
(uiop:native-namestring (trash-error-trash-directory
|
|
condition)))))
|
|
(:documentation "A general error that arose when trashing files."))
|
|
|
|
(define-condition cross-device-error (trash-error)
|
|
((source :accessor cross-device-error-source
|
|
:type (or pathname string)
|
|
:initarg :source
|
|
:documentation "The file being moved by the operation.")
|
|
(target :accessor cross-device-error-target
|
|
:type (or pathname string)
|
|
:initarg :target
|
|
:documentation "The destination of the move operation."))
|
|
(:report (lambda (condition stream)
|
|
(format stream "~S and ~S lie on different devices"
|
|
(uiop:native-namestring
|
|
(cross-device-error-source condition))
|
|
(uiop:native-namestring
|
|
(cross-device-error-target condition)))))
|
|
(:documentation "An error that arose when moving files across devices."))
|
|
|
|
(define-condition file-exists-error (file-error)
|
|
()
|
|
(:report (lambda (condition stream)
|
|
(format stream "File exists: ~S"
|
|
(uiop:native-namestring (file-error-pathname condition)))))
|
|
(:documentation "An error representing the case that a file already exists."))
|
|
|
|
(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 (uiop:parse-unix-namestring ".local/share/")
|
|
(user-homedir-pathname)))
|
|
((pathnamep homedir)
|
|
(merge-pathnames (uiop:parse-unix-namestring ".local/share/")
|
|
(uiop:ensure-directory-pathname homedir)))
|
|
(t
|
|
(merge-pathnames (uiop:parse-unix-namestring ".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)
|
|
(uiop:ensure-directory-pathname
|
|
(merge-pathnames #P"Trash" (xdg-data-home :homedir homedir))))
|
|
|
|
(declaim (ftype (function (integer) t) sticky-bit-set-p)
|
|
(inline sticky-bit-set-p))
|
|
(defun sticky-bit-set-p (mode)
|
|
"Return non-nil if the sticky bit is set in MODE."
|
|
(not (zerop (logand mode #o1000))))
|
|
|
|
(declaim (ftype (function ((or string pathname) &optional t)
|
|
(or null osicat-posix:stat))
|
|
stat)
|
|
(inline stat))
|
|
(defun stat (path &optional lstat)
|
|
"Call the stat(2) system call on PATH. With LSTAT, use lstat(2) instead."
|
|
(let ((path (directory-as-file-pathname
|
|
(ensure-nonwild-pathname path))))
|
|
(handler-case
|
|
(if lstat
|
|
(osicat-posix:lstat path)
|
|
(osicat-posix:stat path))
|
|
(osicat-posix:posix-error () nil))))
|
|
|
|
(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 ((uid (osicat-posix:getuid))
|
|
(top-path (ensure-nonwild-pathname toplevel :ensure-directory t))
|
|
found)
|
|
(flet ((check (dir)
|
|
(let ((stat (stat dir t)))
|
|
(when (and stat
|
|
(osicat-posix:s-isdir (osicat-posix:stat-mode stat))
|
|
(eql (osicat-posix:stat-uid stat) uid))
|
|
(push (uiop:ensure-directory-pathname dir) found)))))
|
|
(check (merge-pathnames (pathname (format nil ".Trash-~D" uid)) top-path))
|
|
(let* ((dir (uiop:ensure-directory-pathname
|
|
(merge-pathnames #P".Trash" top-path)))
|
|
(stat (stat dir t)))
|
|
(when (and stat
|
|
(osicat-posix:s-isdir (osicat-posix:stat-mode stat))
|
|
(sticky-bit-set-p (osicat-posix:stat-mode stat)))
|
|
(check (merge-pathnames (pathname (format nil "~D" uid)) dir))))
|
|
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) &optional list) (or pathname null))
|
|
maybe-create-toplevel-trash-dir))
|
|
(defun maybe-create-toplevel-trash-dir (root &optional ignored-trash-dirs)
|
|
"Return or (if it's safe to) create a toplevel trash directory in
|
|
ROOT. IGNORED-TRASH-DIRS must be directory paths that are not wild!"
|
|
(let ((root (ensure-nonwild-pathname root :ensure-directory t))
|
|
(uid (osicat-posix:getuid)))
|
|
(or
|
|
;; root/.Trash/$UID
|
|
(let* ((outer (uiop:ensure-directory-pathname
|
|
(merge-pathnames #P".Trash" root)))
|
|
(outer-stat (stat outer t)))
|
|
(when (and outer-stat
|
|
(osicat-posix:s-isdir (osicat-posix:stat-mode outer-stat))
|
|
(sticky-bit-set-p (osicat-posix:stat-mode outer-stat)))
|
|
(let* ((inner (uiop:ensure-directory-pathname
|
|
(merge-pathnames (pathname (princ-to-string uid))
|
|
outer)))
|
|
(inner-stat (stat inner t)))
|
|
(unless (member inner ignored-trash-dirs :test #'uiop:pathname-equal)
|
|
(if inner-stat
|
|
(and (osicat-posix:s-isdir (osicat-posix:stat-mode inner-stat))
|
|
(eql uid (osicat-posix:stat-uid inner-stat))
|
|
inner)
|
|
(handler-case
|
|
(progn
|
|
(osicat-posix:mkdir (uiop:native-namestring inner)
|
|
#o0700)
|
|
inner)
|
|
(osicat-posix:posix-error () nil)))))))
|
|
;; root/.Trash-$UID
|
|
(let* ((dir (uiop:ensure-directory-pathname
|
|
(merge-pathnames (format nil ".Trash-~D" uid) root)))
|
|
(stat (stat dir t)))
|
|
(unless (member dir ignored-trash-dirs :test #'uiop:pathname-equal)
|
|
(if stat
|
|
(and (osicat-posix:s-isdir (osicat-posix:stat-mode stat))
|
|
(eql uid (osicat-posix:stat-uid stat))
|
|
dir)
|
|
(handler-case
|
|
(progn
|
|
(osicat-posix:mkdir (uiop:native-namestring dir)
|
|
#o0700)
|
|
dir)
|
|
(osicat-posix:posix-error () nil))))))))
|
|
|
|
(declaim (ftype (function ((or pathname string) &optional list) (or null pathname))
|
|
trash-directory-for-file))
|
|
(defun trash-directory-for-file (path &optional ignored-trash-dirs)
|
|
"Return the trash directory into which PATH should be trashed."
|
|
(let* ((ignored-trash-dirs
|
|
(mapcar (lambda (elt) (ensure-nonwild-pathname
|
|
elt :ensure-directory t))
|
|
ignored-trash-dirs))
|
|
(res-path (ensure-nonwild-pathname path))
|
|
(root (find-filesystem-root res-path))
|
|
(home-trash (let ((ht (user-home-trash-directory)))
|
|
(unless (member ht ignored-trash-dirs
|
|
:test #'uiop:pathname-equal)
|
|
ht))))
|
|
(if (and (path-in-home-directory-p res-path)
|
|
(uiop:pathname-equal
|
|
(find-filesystem-root (user-home-trash-directory)) root))
|
|
home-trash
|
|
(or (maybe-create-toplevel-trash-dir root ignored-trash-dirs)
|
|
home-trash))))
|
|
|
|
(defun rename-safely (source target)
|
|
"Move SOURCE to TARGET, signaling an error if TARGET already exists."
|
|
(let ((source (ensure-nonwild-pathname source))
|
|
(target (ensure-nonwild-pathname target)))
|
|
;; without specific OS and file-system support, it's impossible to do theses
|
|
;; two operations atomically, so we settle for this
|
|
(when (probe-file target)
|
|
(error 'file-exists-error :pathname target))
|
|
(osicat-posix:rename (uiop:native-namestring source)
|
|
(uiop:native-namestring target))))
|
|
|
|
(declaim (ftype (function ((or pathname string) (or pathname string)) t)
|
|
copy-file))
|
|
(defun copy-file (source target)
|
|
"Copy the normal file SOURCE to TARGET. Error if TARGET already exists."
|
|
(with-open-file (in (ensure-nonwild-pathname source)
|
|
:direction :input
|
|
:if-does-not-exist :error)
|
|
(with-open-file (out (ensure-nonwild-pathname target)
|
|
:direction :output
|
|
:if-exists :error)
|
|
(uiop:copy-stream-to-stream in out))))
|
|
|
|
(declaim (ftype (function ((or string pathname)
|
|
(or string pathname)
|
|
&key (:no-cross-device t))
|
|
t)
|
|
move-or-copy-files))
|
|
(defun move-or-copy-files (source target &key no-cross-device)
|
|
"Either or move or copy SOURCE to TARGET. Copy SOURCE if it is a regular file
|
|
and SOURCE and TARGET lie on different devices. With NO-CROSS-DEVICE, don't
|
|
ever copy and instead signal an error. Always error if SOURCE is a directory and
|
|
SOURCE and TARGET lie on different devices."
|
|
(let ((source (ensure-nonwild-pathname source))
|
|
(target (ensure-nonwild-pathname target)))
|
|
(handler-case
|
|
(rename-safely source target)
|
|
(osicat-posix:exdev ()
|
|
(if (or no-cross-device
|
|
(uiop:directory-exists-p source))
|
|
(error 'cross-device-error :source source
|
|
:target target)
|
|
(progn
|
|
(copy-file source target)
|
|
(delete-file source)))))))
|
|
|
|
(declaim (ftype (function ((or pathname string)
|
|
&key
|
|
(:no-cross-device t)
|
|
(:ignored-trash-dirs list)
|
|
(:update-size-cache t)
|
|
(:trash-directory (or null string pathname)))
|
|
t)
|
|
trash-file))
|
|
(defun trash-file (path &key no-cross-device ignored-trash-dirs
|
|
(update-size-cache t) trash-directory)
|
|
"Move PATH to the trash. Specifically, move it to the proper trash as
|
|
specified by the XDG standard. If UPDATE-SIZE-CACHE is non-nil (the default)
|
|
also update the directory size cache. If NO-CROSS-DEVICE is non-nil, don't trash
|
|
files to directories on other devices. Also, don't move files to trash
|
|
directories in IGNORED-TRASH-DIRS. With TRASH-DIRECTORY, force trashing to a
|
|
specific directory."
|
|
(let* ((path (merge-pathnames (ensure-nonwild-pathname path) (uiop:getcwd)))
|
|
(trash-directory (if trash-directory
|
|
(ensure-nonwild-pathname trash-directory
|
|
:ensure-directory t)
|
|
(trash-directory-for-file path ignored-trash-dirs)))
|
|
(files-dir (ensure-directories-exist
|
|
(uiop:ensure-directory-pathname
|
|
(merge-pathnames #P"files" trash-directory))
|
|
:verbose nil))
|
|
(trashinfo (make-trashinfo-for trash-directory path))
|
|
(target (merge-pathnames (make-pathname
|
|
:name (trashinfo-name trashinfo))
|
|
files-dir)))
|
|
(handler-bind
|
|
((t (lambda (e)
|
|
(declare (ignore e))
|
|
(delete-file (trashinfo-info-file trashinfo)))))
|
|
(move-or-copy-files path target :no-cross-device no-cross-device))
|
|
(when update-size-cache
|
|
(trashed-file-size trash-directory (trashinfo-name trashinfo)))))
|
|
|
|
(declaim (ftype (function ((or pathname string list)) list)
|
|
normalize-trash-directories)
|
|
(inline normalize-trash-directories))
|
|
(defun normalize-trash-directories (trash-directories)
|
|
"Normalize TRASH-DIRECTORIES to a non-wild list of pathnames."
|
|
(if (or (stringp trash-directories) (pathnamep trash-directories))
|
|
(list (ensure-nonwild-pathname trash-directories :ensure-directory t))
|
|
(mapcar #'(lambda (elt)
|
|
(ensure-nonwild-pathname elt :ensure-directory t))
|
|
trash-directories)))
|
|
|
|
(declaim (ftype (function (pathname t) list) list-trashed-files-for-directory))
|
|
(defun list-trashed-files-for-directory (trash-directory include-missing)
|
|
"Return a list of trashinfo objects for every trashed file in
|
|
TRASH-DIRECTORY."
|
|
(let ((info-dir (uiop:ensure-directory-pathname
|
|
(merge-pathnames #P"info" trash-directory))))
|
|
(mapcan #'(lambda (path)
|
|
(let ((name (file-or-dir-namestring path)))
|
|
(when (uiop:string-suffix-p name ".trashinfo")
|
|
(handler-case
|
|
(let ((trashinfo (parse-trashinfo-file
|
|
trash-directory
|
|
(subseq
|
|
name 0 (- (length name)
|
|
(length ".trashinfo"))))))
|
|
(when (or include-missing
|
|
(probe-file
|
|
(trashinfo-trashed-file trashinfo)))
|
|
(list trashinfo)))
|
|
(trashinfo-format-error ())))))
|
|
(uiop:directory-files info-dir))))
|
|
|
|
(declaim (ftype (function (&optional (or pathname string list) t) list)
|
|
list-trashed-files))
|
|
(defun list-trashed-files
|
|
(&optional (trash-directories (list-trash-directories))
|
|
include-missing)
|
|
"Return a list of trashinfo objects for each trashed file in
|
|
TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path. With
|
|
INCLUDE-MISSING, also include trashinfo files that are missing their
|
|
corresponding trashed file."
|
|
(mapcan (lambda (dir)
|
|
(list-trashed-files-for-directory dir include-missing))
|
|
(normalize-trash-directories trash-directories)))
|
|
|
|
(declaim (ftype (function (trashinfo &key (:target (or string pathname))
|
|
(:update-size-cache t)
|
|
(:no-cross-device t))
|
|
t)
|
|
restore-file))
|
|
(defun restore-file (trashinfo &key
|
|
(target (trashinfo-original-path trashinfo
|
|
:resolve t))
|
|
(update-size-cache t)
|
|
no-cross-device)
|
|
"Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil
|
|
(the default), also update the directory size cache."
|
|
(let ((source (trashinfo-trashed-file trashinfo))
|
|
(target (ensure-nonwild-pathname target)))
|
|
(move-or-copy-files source target :no-cross-device no-cross-device)
|
|
(handler-bind
|
|
;; attempt to re-trash the file in case of error
|
|
((t #'(lambda (e)
|
|
(move-or-copy-files target source
|
|
:no-cross-device no-cross-device)
|
|
(signal e))))
|
|
(delete-file (trashinfo-info-file trashinfo))
|
|
(when update-size-cache
|
|
(trashed-file-size (trashinfo-trash-directory trashinfo)
|
|
(trashinfo-name trashinfo))))))
|
|
|
|
(declaim (ftype (function (trashinfo &key (:dry-run t)) t) empty-file))
|
|
(defun empty-file (trashinfo &key (dry-run t))
|
|
"Remove the file represented by TRASHINFO from the trash by deleting it. With
|
|
DRY-RUN, don't actually delete anything."
|
|
(let ((trashed-file (trashinfo-trashed-file trashinfo))
|
|
(info-file (trashinfo-info-file trashinfo))
|
|
(trash-directory (trashinfo-trash-directory trashinfo))
|
|
(name (trashinfo-name trashinfo)))
|
|
(if dry-run
|
|
(format t "Deleting ~S~%Deleting ~S~%"
|
|
(uiop:native-namestring info-file)
|
|
(uiop:native-namestring trashed-file))
|
|
(handler-case
|
|
(progn
|
|
(delete-file info-file)
|
|
(if (uiop:directory-exists-p trashed-file)
|
|
(uiop:delete-directory-tree
|
|
(uiop:ensure-directory-pathname trashed-file)
|
|
:validate t
|
|
:if-does-not-exist :ignore)
|
|
(delete-file trashed-file))
|
|
(trashed-file-size trash-directory name))))))
|
|
|
|
(declaim (ftype (function ((or string pathname)) list) directory-files))
|
|
(defun directory-files (dir)
|
|
"Return a list of each file (inode) in DIR."
|
|
(uiop:directory* (merge-pathnames
|
|
uiop:*wild-file-for-directory*
|
|
(ensure-nonwild-pathname dir :ensure-directory t))))
|
|
|
|
(declaim (ftype (function (&optional (or list string pathname) t) t) empty-all))
|
|
(defun empty-all (&optional (trash-directories (list-trash-directories))
|
|
(dry-run t))
|
|
"Empty each of TRASH-DIRECTORIES (defaulting to all known directories). With
|
|
DRY-RUN just print the directories that will be removed without actually doing
|
|
anything."
|
|
(dolist (trashinfo (list-trashed-files trash-directories))
|
|
(empty-file trashinfo :dry-run dry-run)))
|
|
|
|
(declaim (ftype (function ((or string pathname)) (integer 0))
|
|
trash-directory-size))
|
|
(defun trash-directory-size (directory)
|
|
"Return the size of all files trashed in DIRECTORY."
|
|
(loop for info in (list-trashed-files directory)
|
|
summing (or (trashed-file-size
|
|
(trashinfo-trash-directory info)
|
|
(trashinfo-name info))
|
|
0)))
|