Finish library and start work on command

cl-xdg-trash/cl-xdg-trash.asd

@@ -16,7 +16,7 @@
    (:file "trash"))
   :long-description
   #.(uiop:read-file-string
-     (uiop:subpathname *load-pathname* "README.md")))
+     (uiop:subpathname *load-pathname* "../README.md")))
 
 (defsystem #:cl-xdg-trash/tests
   :description "Tests for cl-xdg-trash"

cl-xdg-trash/directorysizes.lisp

@@ -71,7 +71,7 @@ part of STRING."
 
 (declaim (ftype (function ((or string pathname)) pathname)
                 calculate-direcotrysizes-path))
-(defun calculate-direcotrysizes-path (trash-directory)
+(defun calculate-directorysizes-path (trash-directory)
   "Return the directorysizes file for TRASH-DIRECTORY."
   (merge-pathnames #P"directorysizes"
                    (ensure-nonwild-pathname trash-directory
@@ -109,7 +109,7 @@ it."
 (defun trashed-file-size (trash-directory name)
   "Return the size of the trashed file NAME in TRASH-DIRECTORY. If NAME is a
 directory and the file size cache is out of date, update it."
-  (let* ((directorysizes-path (calculate-direcotrysizes-path trash-directory))
+  (let* ((directorysizes-path (calculate-directorysizes-path trash-directory))
          (directorysizes (handler-case
                              (read-directorysizes-file directorysizes-path)
                            (file-error ()

cl-xdg-trash/package.lisp

@@ -59,11 +59,22 @@
                 #:compute-trashinfo-source-file)
   (:export #:read-directorysizes-file
            #:prase-directorysizes
-           #:trashed-file-size))
+           #:trashed-file-size
+           #:calculate-directorysizes-path))
 
 (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 #:cl-xdg-trash/directorysizes)
-  (:export))
+  (:export #:xdg-data-home
+           #:user-home-trash-directory
+           #:valid-toplevel-trash-dir-p
+           #:list-toplevel-trash-directories
+           #:list-trash-directories
+           #:trash-directory-for-file
+           #:trash-file
+           #:list-trashed-files
+           #:restore-file
+           #:empty-file
+           #:empty-all))

cl-xdg-trash/trash.lisp

@@ -1,10 +1,5 @@
 (in-package :cl-xdg-trash)
 
-(declaim (ftype (function () integer) getuid))
-(defun getuid ()
-  "Return the current user's UID."
-  (osicat-posix:getuid))
-
 (declaim (ftype (function (&key (:homedir (or pathname string null))) pathname)
                 xdg-data-home))
 (defun xdg-data-home (&key homedir)
@@ -28,19 +23,52 @@
 (defun user-home-trash-directory (&key homedir)
   (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 (ash mode -9) 1))))
+
+(declaim (ftype (function ((or string pathname)) t) valid-toplevel-trash-dir-p))
+(defun valid-toplevel-trash-dir-p (path)
+  "Return non-nil if PATH is a valid toplevel trash directory. That is, it
+exists, is a directory, and: (1) is owned by the current user, (2) has the
+sticky bit set."
+  (flet ((check-dir (path)
+           (handler-case
+               (let* ((path (ensure-nonwild-pathname path))
+                      (stat (osicat-posix:stat path)))
+                 (and (osicat-posix:s-isdir (osicat-posix:stat-mode stat))
+                      (or (sticky-bit-set-p (osicat-posix:stat-mode stat))
+                          ;; has to come second as this will throw if it fails
+                          (osicat-posix:access path (logior osicat-posix:r-ok
+                                                            osicat-posix:w-ok)))))
+             (osicat-posix:posix-error () nil))))
+    (let* ((path (ensure-nonwild-pathname path :ensure-directory t))
+           (dir-sizes-path (calculate-directorysizes-path path)))
+      (and (uiop:directory-exists-p path)
+           (check-dir (merge-pathnames "info" path))
+           (check-dir (merge-pathnames "files" path))
+           (if (not (uiop:file-exists-p dir-sizes-path))
+               (check-dir path)
+               (handler-case (osicat-posix:access dir-sizes-path
+                                                  (logior osicat-posix:r-ok
+                                                          osicat-posix:w-ok))
+                 (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 ((top-path (ensure-nonwild-pathname toplevel :ensure-directory t))
         found)
     (let ((dir (merge-pathnames #P".Trash" top-path)))
-      (when (uiop:directory-exists-p dir)
+      (when (valid-toplevel-trash-dir-p dir)
         (push dir found)))
-    (let ((uid (getuid)))
+    (let ((uid (osicat-posix:getuid)))
       (when uid
         (let ((dir (merge-pathnames (pathname (format nil ".Trash-~D" uid))
                                     top-path)))
-          (when (uiop:directory-exists-p dir)
+          (when (valid-toplevel-trash-dir-p dir)
             (push dir found)))))
     found))
 
@@ -107,7 +135,7 @@ also update the directory size cache."
               trash-directories)))
 
 (declaim (ftype (function (pathname) list) list-trashed-files-for-directory))
-(defun list-trasheds-file-for-directory (trash-directory)
+(defun list-trashed-files-for-directory (trash-directory)
   "Return a list of trashinfo objects for every trashed file in
 TRASH-DIRECTORY."
   (let ((info-dir (merge-pathnames #P"info/" trash-directory)))
@@ -121,28 +149,67 @@ TRASH-DIRECTORY."
             (uiop:directory-files info-dir))))
 
 (declaim (ftype (function (&optional (or pathname string list)) list)
-                normalize-trash-directories))
+                list-trashed-files))
 (defun list-trashed-files (&optional (trash-directories (list-trash-directories)))
   "Return a list of trashinfo objects for each trashed file in
 TRASH-DIRECTORIES. TRASH-DIRECTORIES can also be a single path."
-  (mapcan #'list-trashed-file-for-directory
+  (mapcan #'list-trashed-files-for-directory
           (normalize-trash-directories trash-directories)))
 
-(declaim (ftype (function (trashinfo &optional t) t) restore-file))
+(declaim (ftype (function (trashinfo &optional (or string pathname) t) t)
-(defun restore-file (trashinfo &optional (update-size-cache t))
+                restore-file))
+(defun restore-file (trashinfo &optional
+                                 (target (trashinfo-original-path
+                                          trashinfo))
+                                 (update-size-cache t))
   "Restore the file pointed to by TRASHINFO. If UPDATE-SIZE-CACHE is non-nil
 (the default), also update the directory size cache."
-  (osicat-posix:rename
+  (let ((target (ensure-nonwild-pathname target)))
-   (uiop:native-namestring (trashinfo-trashed-file trashinfo))
+    (osicat-posix:rename
-   (uiop:native-namestring (trashinfo-original-path trashinfo)))
+     (uiop:native-namestring (trashinfo-trashed-file trashinfo))
+     (uiop:native-namestring target)))
   (handler-bind
       ;; attempt to re-trash the file in case of error
       ((t #'(lambda (e)
               (osicat-posix:rename
-               (uiop:native-namestring (trashinfo-original-path trashinfo))
+               (uiop:native-namestring target)
                (uiop:native-namestring (trashinfo-trashed-file trashinfo)))
               (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~%" info-file trashed-file)
+        (handler-case
+            (progn
+              (delete-file info-file)
+              (uiop:delete-directory-tree trashed-file
+                                          :validate t
+                                          :if-does-not-exist :ignore)
+              (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)))

clash/.gitignore

@@ -0,0 +1 @@
+clash

clash/Makefile

@@ -0,0 +1,6 @@
+LISP=sbcl
+
+clash: clash.asd clash.lisp
+	$(LISP) --eval '(ql:quickload :clash)' \
+			--eval '(asdf:make :clash)' \
+			--eval '(uiop:quit)'

clash/clash.asd

@@ -0,0 +1,14 @@
+(defsystem #:clash
+  :version "0.1.0"
+  :description "Command line interface to the XDG trashcan."
+  :author "Alexander Rosenberg <zanderpkg@pm.me>"
+  :maintainer "Alexander Rosenberg <zanderpkg@pm.me>"
+  :homepage "https://git.zander.im/Zander671/cl-xdg-trash"
+  :license "GPL3"
+  :depends-on (#:cl-xdg-trash #:cl-ppcre #:clingon)
+  :serial t
+  :components
+  ((:file "clash"))
+  :build-operation "program-op"
+  :build-pathname "clash"
+  :entry-point "clash:toplevel")

clash/clash.lisp

@@ -0,0 +1,359 @@
+(defpackage clash
+  (:documentation "Command line interface to the XDG trashcan.")
+  (:import-from #:cl-xdg-trash/trashinfo
+                #:trashinfo-original-path
+                #:trashinfo-trash-directory
+                #:trashinfo-info-file
+                #:trashinfo-name
+                #:trashinfo-trashed-file
+                #:trashinfo-deletion-date)
+  (:import-from #:cl-xdg-trash/mountpoints
+                #:file-or-dir-namestring)
+  (:use #:cl)
+  (:export #:toplevel))
+
+(in-package :clash)
+
+;; remove extra newline at the end of the usage message
+(defmethod clingon:print-usage :around (command stream &key)
+  (let ((msg (with-output-to-string (str-stream)
+               (call-next-method command str-stream))))
+    (format stream "~A" (subseq msg 0 (1- (length msg))))))
+
+
+;; Filtering
+(defun clingon-filtering-options ()
+  "Return some options that can be used by many commands for filtering."
+  (list
+   (clingon:make-option
+    :flag
+    :key :print-format-info
+    :description "print information about format strings, then exit"
+    :long-name "format-info")
+   (clingon:make-option
+    :flag
+    :key :strings
+    :description "don't use regexp to match file names"
+    :short-name #\s
+    :long-name "strings")
+   (clingon:make-option
+    :flag
+    :key :exact
+    :description "force exact match"
+    :short-name #\e
+    :long-name "exact")
+   (clingon:make-option
+    :flag
+    :key :full-path
+    :description "match against full file paths"
+    :short-name #\p
+    :long-name "full-paths")
+   (clingon:make-option
+    :flag
+    :key :case-insensitive
+    :description "match case-insensitively"
+    :short-name #\i
+    :long-name "case-insensitive")
+   (clingon:make-option
+    :flag
+    :key :invert
+    :description "invert result"
+    :short-name #\v
+    :long-name "invert")
+   (clingon:make-option
+    :string
+    :key :format
+    :description "format to print results in"
+    :short-name #\f
+    :long-name "format")))
+
+(declaim (inline compare-trashinfo-to-string))
+(defun compare-trashinfo-to-string (trashinfo filter full-path exact
+                                    case-insensitive)
+  "Compare TRASHINFO's name or path to FILTER using the provided matching
+options."
+  (let* ((orig-path (trashinfo-original-path trashinfo))
+         (target (if full-path orig-path (file-or-dir-namestring orig-path))))
+    (cond
+      ((and exact case-insensitive) (equalp target filter))
+      (exact (equal target filter))
+      (t (search filter target :test (if case-insensitive #'equalp #'eql))))))
+
+(declaim (inline compare-trashinfo-to-scanner))
+(defun compare-trashinfo-to-scanner (trashinfo filter full-path exact)
+  "Compare TRASHINFO's name or path to FILTER, which is a cl-ppcre scanner."
+  (let* ((orig-path (trashinfo-original-path trashinfo))
+         (target (if full-path orig-path (file-or-dir-namestring orig-path))))
+    (destructuring-bind (start &optional end &rest ignore)
+        (multiple-value-list (cl-ppcre:scan filter target))
+      (declare (ignore ignore))
+      (and start
+           (or (not exact)
+               (and (= start 0) (= end (length target))))))))
+
+(defun filter-trashinfos-by (trashinfos filter &key regexp full-path
+                                                 exact case-insensitive
+                                                 invert)
+  "Filter the list of trashinfo objects TRASHINFOS by FILTER, which is a
+string."
+  (if regexp
+      (let ((scanner (cl-ppcre:create-scanner
+                      filter :case-insensitive-mode case-insensitive)))
+        (remove-if
+         (lambda (info)
+           (let ((res (compare-trashinfo-to-scanner info scanner
+                                                    full-path exact)))
+             (or (and (not invert) (not res))
+                 (and invert res))))
+         trashinfos))
+      (remove-if
+       (lambda (info)
+         (let ((res (compare-trashinfo-to-string
+                     info filter full-path exact case-insensitive)))
+           (or (and (not invert) (not res))
+               (and invert res))))
+       trashinfos)))
+
+(defun list-nonexcluded-trash-dirs (cmd)
+  "Return a list of all trash directories, except those excluded by CMD."
+  (set-difference (cl-xdg-trash:list-trash-directories)
+                  (clingon:getopt cmd :ignored-trashes)
+                  :test #'uiop:pathname-equal))
+
+(defun list-trashinfos-for-cmd (cmd)
+  "List trashinfos for the command CMD."
+  (let ((args (clingon:command-arguments cmd)))
+    (when (cdr args)
+      (clingon:print-usage-and-exit cmd t))
+    (if (not (car args))
+        (cl-xdg-trash:list-trashed-files (list-nonexcluded-trash-dirs cmd))
+        (let ((filter (car args))
+              (strings (clingon:getopt cmd :strings))
+              (exact (clingon:getopt cmd :exact))
+              (full-path (clingon:getopt cmd :full-path))
+              (case-insensitive (clingon:getopt cmd :case-insensitive))
+              (invert (clingon:getopt cmd :invert)))
+          (filter-trashinfos-by
+           (cl-xdg-trash:list-trashed-files
+            (list-nonexcluded-trash-dirs cmd))
+           filter
+           :regexp (not strings)
+           :exact exact
+           :full-path full-path
+           :case-insensitive case-insensitive
+           :invert invert)))))
+
+
+;; Formatting
+(defparameter *trashinfo-formatters*
+  `((#\o . ,(lambda (stream info)
+              "the (o)riginal path"
+              (format stream "~A" (trashinfo-original-path info))))
+    (#\n . ,(lambda (stream info)
+              "the original (n)ame"
+              (format stream "~A" (file-or-dir-namestring
+                                   (trashinfo-original-path info)))))
+    (#\d . ,(lambda (stream info)
+              "the trash (d)irectory"
+              (format stream "~A" (trashinfo-trash-directory info))))
+    (#\i . ,(lambda (stream info)
+              "the trash(i)nfo file path"
+              (format stream "~A" (trashinfo-info-file info))))
+    (#\c . ,(lambda (stream info)
+              "the (c)urrent (trashed) path"
+              (format stream "~A" (trashinfo-trashed-file info))))
+    (#\u . ,(lambda (stream info)
+              "the time the file was trashed (in (u)TC seconds)"
+              (format stream "~A" (local-time:timestamp-to-unix
+                                   (trashinfo-deletion-date info)))))
+    (#\t . ,(lambda (stream info)
+              "the (t)ime the file was trashed (pretty-printed local time)"
+              (local-time:format-timestring
+               stream (trashinfo-deletion-date info)
+               :format local-time:+asctime-format+)))
+    (#\% . ,(lambda (stream info)
+              "a liternal %"
+              (declare (ignore info))
+              (format stream "%")))))
+
+(defun process-format-string (format-string)
+  "Process FORMAT-STRING into a list of string and functions."
+  (let ((start 0)
+        out end)
+    (labels ((ensure-next-char (i thing)
+               (unless (< i (1- (length format-string)))
+                 (error "Unterminated ~A at char ~A: ~S" thing i format-string)))
+             (unknown (i thing)
+               (error "Unknown ~A at char ~A: ~S" thing i format-string))
+             (push-thing (thing)
+               (if (null out)
+                   (setq out (list thing)
+                         end out)
+                   (setf (cdr end) (list thing)
+                         end (cdr end))))
+             (push-string (str)
+               (unless (zerop (length str))
+                 (if (stringp (car end))
+                     (setf (car end) (format nil "~A~A" (car end) str))
+                     (push-thing str)))))
+      (do ((i 0 (1+ i)))
+          ((>= i (length format-string)))
+        (case (aref format-string i)
+          (#\%
+           (ensure-next-char i "substitution")
+           (push-string (subseq format-string start i))
+           (let ((fun (cdr (assoc (aref format-string (1+ i))
+                                  *trashinfo-formatters*))))
+             (unless (functionp fun)
+               (unknown i "substitution"))
+             (push-thing fun))
+           (setq start (+ i 2)
+                 i (1+ i)))
+          (#\\
+           (ensure-next-char i "escape sequence")
+           (push-string (subseq format-string start i))
+           (push-string
+            (case (aref format-string (1+ i))
+              (#\\ "\\")
+              (#\n (string #\Newline))
+              (#\t (string #\Tab))
+              (#\0 (string #\Nul))
+              (t (unknown i "escape sequence"))))
+           (setq start (+ i 2)
+                 i (1+ i)))))
+      (push-string (subseq format-string start))
+      out)))
+
+(defun format-trashinfo (stream format-object info)
+  "Format the trashinfo INFO to STREAM accoring to FORMAT-OBJECT (which is from
+process-format-string)."
+  (dolist (part format-object)
+    (if (stringp part)
+        (format stream "~A" part)
+        (funcall part stream info))))
+
+(defun print-format-info (&optional (stream t))
+  (format stream "~
+Format strings use C-style and printf-style escape sequences. Each character
+other than one of those with a special meaning noted below is copied to the
+output verbatim. The recognized C-style escapes sequences are:
+  \"\\0\" - null byte
+  \"\\n\" - newline
+  \"\\t\" - tab character
+  \"\\\\\" - literal backslash
+The recognizes printf-style sequences are (parenthesis denote the mnemonic):~%")
+  (dolist (entry *trashinfo-formatters*)
+    (let ((char (car entry))
+          (doc (documentation (cdr entry) t)))
+      (format stream "  \"%~A\" - ~A~%" char doc))))
+
+
+;; Sorting
+(defun clingon-sort-options ()
+  "Return a list of sorting options that can be used by many commands."
+  (list
+   (clingon:make-option
+    :flag
+    :key :reverse-sort
+    :description "reverse sort order"
+    :short-name #\r
+    :long-name "reverse-sort")
+   (clingon:make-option
+    :enum
+    :key :sort-field
+    :description "sort field"
+    :short-name #\l
+    :long-name "sort-field"
+    :items '(("name" . :name)
+             ("path" . :path)
+             ("deletion-date" . :deletion-date))
+    :initial-value "deletion-date")))
+
+(defun sort-trashinfos-for-cmd (trashinfos cmd)
+  "Sort the TRASHINFOS according to options passed to CMD."
+  (multiple-value-bind (pred-fun key-fun)
+      (case (clingon:getopt cmd :sort-field)
+        (:name (values #'string-lessp
+                       (lambda (info) (file-or-dir-namestring
+                                       (trashinfo-original-path info)))))
+        (:path (values #'string-lessp #'trashinfo-original-path))
+        (:deletion-date (values
+                         #'< (lambda (info) (local-time:timestamp-to-unix
+                                             (trashinfo-deletion-date info))))))
+    (sort trashinfos
+          (if (clingon:getopt cmd :reverse-sort)
+              (complement pred-fun)
+              pred-fun)
+          :key key-fun)))
+
+
+;; List command
+(defun list/handler (cmd)
+  "Toplevel for the \"list\" subcommand."
+  (if (clingon:getopt cmd :print-format-info)
+      (print-format-info t)
+      (let ((format (process-format-string (or (clingon:getopt cmd :format)
+                                               "%t  %o\\n"))))
+        (dolist (info (sort-trashinfos-for-cmd
+                       (list-trashinfos-for-cmd cmd) cmd))
+          (format-trashinfo t format info)))))
+
+(defun list/options ()
+  "Return options for the \"list\" subcommand."
+  (append
+   (clingon-filtering-options)
+   (clingon-sort-options)))
+
+(defun list/command ()
+  "Return the Clingon command for the \"list\" subcommand."
+  (clingon:make-command
+   :name "list"
+   :description "list files in trash directories"
+   :usage "[pattern]"
+   :options (list/options)
+   :handler #'list/handler))
+
+
+;; Toplevel command
+(defun toplevel/options ()
+  "Return the toplevel options list."
+  (list
+   (clingon:make-option
+    :list
+    :key :ignored-trashes
+    :description "ignore the given trash directory"
+    :long-name "ignore-trash"
+    :persistent t)))
+
+(defun toplevel/command ()
+  "Return the toplevel command."
+  (clingon:make-command
+   :name "clash"
+   :description "command line interface to the XDG trashcan"
+   :version "0.1.0"
+   :license "GPL3"
+   :authors '("Alexander Rosenberg <zanderpkg@pm.me>")
+   :options (toplevel/options)
+   :sub-commands (list (list/command))
+   :handler #'(lambda (cmd)
+                (clingon:print-usage-and-exit cmd t))))
+
+(defparameter *toplevel/help-option*
+  (clingon:make-option
+   :flag
+   :key :clingon.help.flag
+   :description "display usage information, then exit"
+   :short-name #\h
+   :long-name "help"
+   :persistent t)
+  "Help option to replace the default Clingon one.")
+
+(defun toplevel (&optional (args () argsp))
+  "Program entry point.
+Args can be supplied to facilitate testing in SLIME."
+  (let ((clingon:*default-options* (list clingon:*default-version-flag*
+                                         clingon:*default-bash-completions-flag*
+                                         *toplevel/help-option*)))
+    (if argsp
+        (clingon:run (toplevel/command) args)
+        (clingon:run (toplevel/command)))))