diff --git a/cl-xdg-trash/trash.lisp b/cl-xdg-trash/trash.lisp index 5e92f21..189116c 100644 --- a/cl-xdg-trash/trash.lisp +++ b/cl-xdg-trash/trash.lisp @@ -35,6 +35,38 @@ (uiop:native-namestring (file-error-pathname condition))))) (:documentation "An error representing the case that a file already exists.")) +(define-condition file-not-found-error (file-error) + () + (:report (lambda (condition stream) + (format stream "No such file or directory: ~S" + (uiop:native-namestring (file-error-pathname condition))))) + (:documentation "An error representing the case that a file does not exist.")) + +(define-condition two-arg-file-error (file-error) + ((action :accessor two-arg-file-error-action + :type string + :initarg :action + :documentation "The action that caused the problem.") + (detail :accessor two-arg-file-error-detail + :type (or string null) + :initarg :detail + :initform nil + :documentation "A specific error message (e.g. Permission denied).") + (target :accessor two-arg-file-error-target + :type (or string pathname null) + :initarg :target + :initform nil + :documentation "The optional target of the action.")) + (:report (lambda (condition stream) + (let ((target (two-arg-file-error-target condition))) + (format stream "Cannot ~A ~S~@[ to ~S~]~@[: ~A~]" + (two-arg-file-error-action condition) + (uiop:native-namestring (file-error-pathname condition)) + (and target (uiop:native-namestring target)) + (two-arg-file-error-detail condition))))) + (:documentation + "An error that occurred during a two-file operation (rename, etc.).")) + (declaim (ftype (function (&key (:homedir (or pathname string null))) pathname) xdg-data-home)) (defun xdg-data-home (&key homedir) @@ -196,20 +228,60 @@ ROOT. IGNORED-TRASH-DIRS must be directory paths that are not wild!" ;; 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)))) + (handler-case + (osicat-posix:rename (uiop:native-namestring source) + (uiop:native-namestring target)) + (osicat-posix:enoent () + (error 'file-not-found-error :pathname source)) + (osicat-posix:eacces () + (error 'two-arg-file-error :action "rename" + :detail "Permission denied" + :pathname source + :target target))))) + +(declaim (ftype (function (integer integer &key (:buffer-size integer)) integer) + copy-file-descriptor)) +(defun copy-file-descriptor (in out &key (buffer-size 8192)) + "Copy all data from the file descriptor IN to OUT." + (let (buffer) + (unwind-protect + (progn + (setq buffer (cffi:foreign-alloc :char :count buffer-size)) + (loop for read = (osicat-posix:read in buffer buffer-size) + while (plusp read) + do (osicat-posix:write out buffer read) + sum read)) + (when buffer + (cffi:foreign-free buffer))))) (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)))) + (handler-case + (let ((source (ensure-nonwild-pathname source)) + (target (ensure-nonwild-pathname target)) + in out) + (unwind-protect + (progn + (setq in (osicat-posix:open + (uiop:native-namestring source) + osicat-posix:o-rdonly) + out (osicat-posix:open + (uiop:native-namestring target) + (logior osicat-posix:o-wronly osicat-posix:o-creat))) + (copy-file-descriptor in out)) + (when in + (osicat-posix:close in)) + (when out + (osicat-posix:close out)))) + (osicat-posix:enoent () + (error 'file-not-found-error :pathname source)) + (osicat-posix:eacces () + (error 'two-arg-file-error :action "copy" + :detail "Permission denied" + :pathname source + :target target)))) (declaim (ftype (function ((or string pathname) (or string pathname)