A Windows style file deletion system

[Davin Pearson]

;;; trashcan.el --- Windows syle file deletion system
;;
;; Copyright (C) 2006, Davin Pearson
;;
;; Author/Maintainer: Davin Pearson
;; Keywords: Windows Recycle Bin
;; Version: 1.0

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:
;;
;; The file trashcan.el changes the behaviour of deleting files with
;; the "x" key in dired mode. Instead of deleting files permanently,
;; which is Emacs' default behaviour, they are either moved to a
;; Trashcan Directory (the actual directory depends on the value of
;; the string variable trashcan--dir which has a default value of
;; ".TRASHCAN") or if you are already in the trashcan directory, then
;; the files are deleted permanently. Like the Windows Recycle Bin,
;; files in the trashcan can be restored (undeleted) and in Windows
;; for efficiency each hard drive has own trashcan directory. Files
;; can be restored by viewing the trashcan directory in dired mode,
;; selecting the file(s) you wish to restore with the "m" key and then
;; executing the command M-x trashcan--restore. If no files or
;; directories have been selected, then the file or directory
;; currently pointed to by the cursor is restored. Each trashcan
;; directory can be emptied via the command M-x trashcan--empty while
;; you are viewing that directory in dired mode. The name "trashcan"
;; comes from the Amiga Computer's equivalent of the Windows Recycle
;; Bin.

;; See the following URL for the latest documentation and version:
;;
;;
http://www.geocities.com/davinpearson/research/2006/mopa2e.html#trashcan
;;
;;

;;; Code:

(defvar trashcan--dirname ".TRASHCAN"
  "This variable specifies what directory to move files into with the
\"x\" key in dired mode.  Do not add any prefix to the directory such
as \"~/\" or \"/\".

If this is a Windows system, the trashcan directories are located at
the following regexp:

   (concat \"[a-zA-Z]:/\" (regexp-quote trashcan--dirname))

If this is a Unix system, the trashcan directory is located at the
following place:

   (concat (expand-file-name \"~/\") trashcan--dirname)

In Windows, DO NOT give this the same name as the windows RECYCLER
directory as this will confuse the hell out of Windows.
")


;;; (trashcan--split (setq file "d:/home/mylisp/trashcan.el"))
;;; (trashcan--split (setq file "/home/mylisp/trashcan.el"))

(defun trashcan--split (file)
  ;;
  ;; NOTE: this function gives meaningful results for both WINDOWS and
UNIX
  ;;
  (if (string-match "[a-zA-Z]:/" file)
      (cons (substring file 0 3) (substring file 3))
    (cons (expand-file-name "~/") (substring file 1))
    )
  )

;;; (trashcan--encode (setq file "/home/foomatic.txt"))
;;; (trashcan--encode (setq file "d:/home/foomatic.txt"))
;;; (trashcan--encode (setq file "d:/home/mylisp"))
;;; (trashcan--encode (setq file "/home/mylisp/trashcan.el"))
"d:/home/TRASHCAN/home!mylisp!trashcan.el"
;;; (trashcan--encode (setq file "d:/home/mylisp/trashcan.el"))
"d:/TRASHCAN/home!mylisp!trashcan.el"
(defun trashcan--encode (file)
  ;;(debug)

  (let* ((s (trashcan--split file))
         (d (car s))
         (f (cdr s)))

    ;;(debug)
    (let ((i 0))
      (while (< i (length f))
        (if (eq ?/ (aref f i))
            (aset f i ?!))
        (incf i)))

    (let ((new (concat d trashcan--dirname "/" f)))
      (if (file-exists-p new)
          (let ((count 1)
                (result nil))
            (while (file-exists-p (setq result (concat new "." (format
"%d" count))))
              (incf count))
            result)
        new))
    )
  )

;;; (trashcan--split "/home/TRASHCAN/home!mylisp!trashcan.el")
;;; (trashcan--split "d:/TRASHCAN/home!mylisp!trashcan.el")
;;; (trashcan--decode (setq file
"/home/TRASHCAN/home!mylisp!trashcan.el"))
;;; (trashcan--decode (setq file
"d:/TRASHCAN/home!mylisp!trashcan.el"))

(defun trashcan--decode (file)

  (if (string-match (concat "[a-zA-Z]:/" (regexp-quote
trashcan--dirname)) file)
      ;;
      ;; NOTE: we are in DOS mode in this branch
      ;;
      (let ((d (substring file 0 3))
            (f (substring file (+ 4 (length trashcan--dirname))))
            (i 0))
        (while (< i (length f))
          (if (eq ?! (aref f i))
              (aset f i ?/))
          (incf i))
        (concat d f))

    (progn
      ;;
      ;; NOTE: we are in UNIX mode in this branch
      ;;
      (assert (string-match (concat (expand-file-name "~/")
(regexp-quote trashcan--dirname) "/\\(.*\\)$") file))
      (let ((x (substring file (match-beginning 1) (match-end 1)))
            (i 0))
        (while (< i (length x))
          (if (eq ?! (aref x i))
              (aset x i ?/))
          (incf i))
        (concat "/" x)))
    )
  )

(defun trashcan--walk-buffers (sexp)
  (save-window-excursion
    (let ((ptr (buffer-list)))
      (while ptr
        (set-buffer (car ptr))
        (eval sexp)
        (setq ptr (cdr ptr))))))

;;; (trashcan--delete-dangerous (setq file-or-directory
"d:/TRASHCAN/workspace/"))
;;; (trashcan--delete-dangerous (setq file-or-directory "c:/TRASHCAN"))
(defun trashcan--delete-dangerous (file-or-directory)
  "Is better than the built-in function delete-file in that it also
deletes directories,
therefore is more dangerous than delete-file"
  (if (file-exists-p file-or-directory)
      (if (file-directory-p file-or-directory)
          (progn
            ;;(sit-for 2)
            (shell-command (concat "rm -rf \"" file-or-directory "\""))
            ;;(sit-for 2)
            )
        (delete-file file-or-directory))))

(defun trashcan--in-windows-trashcan (&optional OR-SUBDIR)
  "Returns the current trashcan directory if there is one"
  (if OR-SUBDIR
      (if (string-match (concat "^\\([a-zA-Z]:/" (regexp-quote
trashcan--dirname) "\\)")
                        (expand-file-name default-directory))
          (substring (expand-file-name default-directory)
(match-beginning 1) (match-end 1)))
    (if (string-match (concat "^\\([a-zA-Z]:/" (regexp-quote
trashcan--dirname) "\\)/?$")
                      (expand-file-name default-directory))
          (substring (expand-file-name default-directory)
(match-beginning 1) (match-end 1)))))

(defun trashcan--in-unix-trashcan (&optional OR-SUBDIR)
  "Returns the current trashcan directory if there is one"
  (if OR-SUBDIR
      (if (string-match (concat "^" (expand-file-name "~/")
(regexp-quote trashcan--dirname))
                        (expand-file-name default-directory))
          (concat (expand-file-name "~/") trashcan--dirname))
    (if (string-match (concat "^" (expand-file-name "~/") (regexp-quote
trashcan--dirname) "/?$")
                      (expand-file-name default-directory))
          (concat (expand-file-name "~/") trashcan--dirname))
    )
  )

(defun trashcan--in-trashcan (&optional OR-SUBDIR)
  (or (trashcan--in-windows-trashcan OR-SUBDIR)
      (trashcan--in-unix-trashcan OR-SUBDIR)))

(defun trashcan--after-deletion ()
  ;;
  ;; NOTE: conditionally kills file buffers that have been deleted
  ;;
  ;; NOTE: unconditionally kills dired buffers that have been deleted
  ;;
  (let (dirname)
    (cond
     ((setq dirname (trashcan--in-windows-trashcan 'OR-SUBDIR)))
     ((setq dirname (trashcan--in-unix-trashcan    'OR-SUBDIR)))
     (t
      (error "Should never happen")))

    (trashcan--walk-buffers
     '(if (or (and (buffer-file-name)
                   (string-match (concat "^" dirname)
default-directory)
                   (y-or-n-p (concat "Kill buffer " (buffer-file-name)
" too? ")))
              (and (eq major-mode 'dired-mode) (not (file-exists-p
default-directory))))
          (kill-buffer nil))))
  )

(require 'dired)

(defun dired-internal-do-deletions (l arg)

  "This function replaces the function of the same name in the standard
Emacs file dired.el"
  ;;(my-foo)

  (if (not (eq major-mode 'dired-mode))
      (error "You must be in dired mode to do this"))

  (let ((ptr l))
    (while ptr
      (if (or (string-match "/./?$" (caar ptr)) (string-match "/../?$"
(caar ptr)))
          (error "You cannot delete the directories . or .."))
      (setq ptr (cdr ptr))))

  ;;(debug)

  (let ((in-trash (trashcan--in-trashcan 'OR-SUBDIR))
        (files (mapcar (function car) l)))

    ;; NOTE: these two have the same result...
    (setq files (nreverse (mapcar (function dired-make-relative)
files)))
    ;;(setq files (nreverse (mapcar 'dired-make-relative files)))

    ;;(debug)

    (if in-trash
        (if (dired-mark-pop-up " *Deletions*"
                               'delete
                               files
                               dired-deletion-confirmer
                               (format "Permanently Delete %s "
(dired-mark-prompt arg files)))
            (let ((ptr l))
              (while ptr
                (trashcan--delete-dangerous (caar ptr))
                (setq ptr (cdr ptr)))
              (revert-buffer)
              (trashcan--after-deletion)))

      (if (dired-mark-pop-up " *Deletions*"
                               'delete
                               files
                               dired-deletion-confirmer
                               (format "Move to trashcan %s "
(dired-mark-prompt arg files)))
          (let ((ptr l))
            (while ptr
              ;;(message "rename-file %s -> %s" (caar ptr)
"d:/eraseme/")

              ;;(debug)

              (let* ((f (caar ptr))
                     (e (trashcan--encode f))
                     (d (file-name-directory e)))

                ;;(debug)
                (if (not (file-exists-p d))
                    (make-directory d 'PARENTS))

                ;;(debug)

                (rename-file f e) ;; NOTE: this is guaranteed to work
(see function trashcan--encode)

                (trashcan--walk-buffers
                 '(if (and (buffer-file-name) (string-match (concat "^"
(regexp-quote f)) (buffer-file-name)))
                      (let ((n (substring (buffer-file-name) (length
f))))
                        ;;(debug)
                        (set-visited-file-name (concat e n)
'NO-QUERY))))

                (trashcan--walk-buffers
                 '(if (and (eq major-mode 'dired-mode) (not
(file-exists-p (expand-file-name default-directory))))
                      (kill-buffer nil)))

                )
              (setq ptr (cdr ptr)))

            (revert-buffer)

            (trashcan--walk-buffers
             '(if (and (eq major-mode 'dired-mode)
(trashcan--in-trashcan 'OR-SUBDIR))
                  (revert-buffer)))
            )
        )
      )
    )
  )

(defun trashcan--restore ()
  (interactive)
  (let* ((list (dired-get-marked-files))
         (ptr  list))

    (while ptr
      (let* ((source (car ptr))
             (target (trashcan--decode source))
             (fnd    (file-name-directory target)))

        ;;(debug)

        (if (file-exists-p target)
            (error "File %s already exists" target))

        (make-directory fnd 'PARENTS)
        (rename-file source target)

        ;;
        ;; NOTE: are we editing one of the files that we want to
restore?
        ;;
        ;;(trashcan--walk-buffers
        ;; '(if (string= (buffer-file-name) source)
        ;;      (set-visited-file-name target 'NO-QUERY)))

        ;;
        ;; NOTE: are we editing a files of a subdirectory that we want
to restore
        ;;
        (trashcan--walk-buffers
         '(if (and (buffer-file-name) (string-match (concat "^"
(regexp-quote source)) (buffer-file-name)))
              (let ((n (substring (buffer-file-name) (length source))))
                ;;(debug)
                (set-visited-file-name (concat target n) 'NO-QUERY))))

        (trashcan--walk-buffers
         '(if (and (eq major-mode 'dired-mode) (string= fnd
(expand-file-name default-directory)))
              (revert-buffer)))

        (trashcan--walk-buffers
         '(if (and (eq major-mode 'dired-mode) (not (file-exists-p
(expand-file-name default-directory))))
              (kill-buffer nil)))

        )
      (setq ptr (cdr ptr))))

  (trashcan--walk-buffers
   '(if (and (eq major-mode 'dired-mode) (trashcan--in-trashcan
'OR-SUBDIR))
        (revert-buffer)))

  )

(defun trashcan--empty ()
  "Careful when using this command as it cannot be undone"
  (interactive)
  (cond
   ((not (trashcan--in-trashcan))
    (error "You must be in the trashcan to execute this command"))

   ((not (eq major-mode 'dired-mode))
    (error "You must be in dired mode to execute this command"))

   (t
    (if (yes-or-no-p "Really empty trashcan? ")
        (let (dirname)

          (cond
           ((setq dirname (trashcan--in-windows-trashcan)))
           ((setq dirname (trashcan--in-unix-trashcan)))
           (t
            (error "Should never happen")))

          ;;(debug)

          (trashcan--delete-dangerous dirname)

          ;;(audible-beeps "Deleting file %s" dirname)

          (make-directory dirname 'PARENTS)
          (revert-buffer)
          (trashcan--after-deletion))))))

(provide 'trashcan)
;;; trashcan.el ends here