🚀 go-pugleaf

This is my modifications of tree-dired. See the discussion in the
previous article, or the documentation below for details.

;;
;;  File: aho-tree-dired.el
;; 
;;  Author: Anders Holst (aho@sans.kth.se)
;;
;;  Last change: 12 December 1992
;;
;;  Copyright (C) Anders Holst
;;
;;  ----------------------------------------------------------------------
;;  This program 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 1, or (at your option)
;;  any later version.
;; 
;;  This program 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 your copy of Emacs; if not, write to the Free Software
;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;  ----------------------------------------------------------------------
;;
;;  
;;  INSTALLATION
;;
;;  The easiest way to install this, is to put the file in your load-path, 
;;  and add the following to 'dired-load-hook':
;;
;;    (load "aho-tree-dired")
;;    (define-key dired-mode-map "q" 'dired-back)
;;    (define-key dired-mode-map "Q" 'dired-quit)
;;
;;
;;  DESCRIPTION
;;
;;  This file implements the following modifications to tree dired:
;;
;;  * More extensive "window" defaulting in Copy/Rename/Link (searches
;;    all windows for a dired-buffer), together with defaulting to
;;    last directory used (if "window" defaulting fails).
;;  * Sorting in alphabetically of new files/links (if the current sort
;;    order is alphabetical).
;;  * More emphasized tree-structure between the different dired-buffers.
;;    'f' and 'v' climbs (as before) down to a sub-directory, 'q' climbs
;;    back up again. (All dired-buffers in the "dired-buffer-tree" are
;;    kept buried, except the current.) 'Q' jumps out of the entire
;;    "dired-buffer-tree". 
;;
;;  Comments on the modifications:
;;
;;  * Regarding "window" defaulting: I don't know how the changes will
;;    work with for example Epoch, or Emacs 19, since I have never
;;    used Epoch myself. But if every buffer gets a window of it's own
;;    (or have I missunderstood something ?) that might mean that all
;;    dired-buffers have windows, and the defaulting will be
;;    completely useless (i.e. always come up with something, and
;;    probably wrong).
;;  * The defaulting to last used directory works as a second
;;    alternative, when there are no other dired-window to default to.
;;    It is currently activated only together with this window
;;    defaulting, i.e. when the variable 'dired-dwim-target' is non-nil.
;;    Perhaps it should have a variable of its own ?
;;  * Sorting in of new files are done only when sort order is
;;    alphabetical, since that was most easy to do. Perhaps it should
;;    be done also for other sort orders. On the other hand, it might
;;    slow things down a bit to sort (but I havn't noticed anything
;;    such yet). Also on some places there is a local language
;;    sort order which string-lessp follows, instead of the normal
;;    ascii-order which ls uses. I had to work around this in a way
;;    that may make sorting more slow.
;;  * 'q' is not the same as '^'. For example when following a link
;;    '^' goes up one directory on "the other side", but 'q' returns
;;    to the dired-buffer you came from. Also, when in the first
;;    dired-buffer of such a dired-buffer-tree, 'q' quits the tree,
;;    whereas '^' climbs further up ('q' will after such use of '^'
;;    climb back down instead).
;;
;;  NOTE: The modifications in this file has only been tested with
;;  version 6.0 of tree-dired. I don't know how much tree-dired will
;;  change, but at least some of my modifications deals with small
;;  inconveniences in tree-dired, which hopefully might dissapear in
;;  later versions.
;;  These modifications should also work reasonably together with
;;  dired-nstd.el, some strange things of which I have tried to
;;  mitigate. 
;;  


(defvar father-buffer nil)
(make-variable-buffer-local 'father-buffer)

(defun dired-up-directory ()
  "Run dired on parent directory of current directory.
Find the parent directory either in this buffer or another buffer.
Creates a buffer if necessary."
  (interactive)
  (let* ((dir (dired-current-directory))
	 (up (file-name-directory (directory-file-name dir))))
    (or (dired-goto-file (directory-file-name dir))
	(dired-goto-subdir up)
	(let ((buf (current-buffer))
	      (father father-buffer))
	  (bury-buffer)
	  (dired up)
	  (dired-goto-file dir)
	  (if (not (equal father (current-buffer)))
	      (setq father-buffer buf))))))

(defun dired-view-file ()
  "In dired, examine a file in view mode, returning to dired when done.
When file is a directory, show it in this buffer if it is inserted;
otherwise, display it in another buffer."
  (interactive)
  (let ((file (dired-get-filename)))
    (if (file-directory-p file)
	(or (dired-goto-subdir file)
	    (let ((buf (current-buffer))
		  (father father-buffer))
	      (bury-buffer)
	      (dired file)
	      (if (not (equal father (current-buffer)))
		  (setq father-buffer buf))))
	(view-file file))))

(defun dired-find-file ()
  "In dired, visit the file or directory named on this line."
  (interactive)
  (let ((file (dired-get-filename)))
    (if (file-directory-p file)
	(or (dired-goto-subdir file)
	    (let ((buf (current-buffer))
		  (father father-buffer))
	      (bury-buffer)
	      (dired file)
	      (if (not (equal father (current-buffer)))
		  (setq father-buffer buf))))
	(find-file file))))

(defun dired-back ()
  "Return to the dired-buffer this buffer was invoked from.
If none, just bury this buffer"
  (interactive)
  (let ((buf father-buffer))
    (bury-buffer)
    (if (and (bufferp buf)
	     (buffer-name buf))
	(if (get-buffer-window buf)
	    (select-window (get-buffer-window buf))
	    (switch-to-buffer buf)))))

(defun dired-quit ()
  "Bury the current dired buffer."
  (interactive)
  (bury-buffer))

(defvar dired-last-used-directory () 
	"Default directory in copy/rename/link file")
(make-variable-buffer-local 'dired-last-used-directory)

(defun dired-default-target-directory ()
  ;; Try to guess which target directory the user may want.
  ;; If there is a dired buffer displayed in the next window, use
  ;; its current subdir, else last used diredctory if any, else
  ;; use current subdir of this dired buffer.
  (let ((this-dir (and (eq major-mode 'dired-mode)
		       (dired-current-directory))))
    (if dired-dwim-target
	(let* ((this-window (selected-window))
	       (other-window (next-window this-window))
	       other-dir)
	  (while (not (or (equal this-window other-window)
			  other-dir))
	    (set-buffer (window-buffer other-window))
	    (setq other-dir (and (eq major-mode 'dired-mode)
				 (dired-current-directory)))
	    (setq other-window (next-window other-window)))
	  (set-buffer (window-buffer this-window))
	  (or other-dir dired-last-used-directory this-dir))
      this-dir)))

(defun dired-do-create-files (op-symbol file-creator operation arg
					     &optional marker-char op1
					     how-to)
  ;; Create a new file for each marked file.
  ;; Prompts user for target, which is a directory in which to create
  ;;   the new files.  Target may be a plain file if only one marked
  ;;   file exists.
  ;; OP-SYMBOL is the symbol for the operation.  Function `dired-mark-pop-up'
  ;;   will determine wether pop-ups are appropriate for this OP-SYMBOL.
  ;; FILE-CREATOR and OPERATION as in dired-create-files.
  ;; ARG as in dired-mark-get-files.
  ;; Optional arg OP1 is an alternate form for OPERATION if there is
  ;;   only one file.
  ;; Optional arg MARKER-CHAR as in dired-create-files.
  ;; Optional arg HOW-TO determines how to treat target:
  ;;   If HOW-TO is not given (or nil), and target is a directory, the
  ;;     file(s) are created inside the target directory.  If target
  ;;     is not a directory, there must be exactly one marked file,
  ;;     else error.
  ;;   If HOW-TO is t, then target is not modified.  There must be
  ;;     exactly one marked file, else error.
  ;; Else HOW-TO is assumed to be a function of one argument, target,
  ;;     that looks at target and returns a value for the into-dir
  ;;     variable.  The function dired-into-dir-with-symlinks is provided
  ;;     for the case (common when creating symlinks) that symbolic
  ;;     links to directories are not to be considered as directories
  ;;     (as file-directory-p would if HOW-TO had been nil).
  (or op1 (setq op1 operation))
  (let* ((fn-list (dired-mark-get-files nil arg))
	 (fn-count (length fn-list))
	 (target (expand-file-name
		   (dired-mark-read-file-name
		    (concat (if (= 1 fn-count) op1 operation) " %s to: ")
		    (dired-default-target-directory)
		    op-symbol arg (mapcar (function dired-make-relative) fn-list))))
	 (into-dir (cond ((null how-to) (file-directory-p target))
			 ((eq how-to t) nil)
			 (t (funcall how-to target)))))
    (if (and (> fn-count 1)
	     (not into-dir))
	(error "Marked %s: target must be a directory: %s" operation target))
    ;; rename-file bombs when moving directories unless we do this:
    (or into-dir (setq target (directory-file-name target)))
    (setq dired-last-used-directory (if into-dir
					(file-name-as-directory target)
					(file-name-directory target)))
    (dired-create-files
     file-creator operation fn-list
     (if into-dir			; target is a directory
	 ;; This function uses fluid vars into-dir and target when called
	 ;; inside dired-create-files:
	 (function (lambda (from)
		     (expand-file-name (file-name-nondirectory from) target)))
       (function (lambda (from) target)))
     marker-char)))

(defun dired-create-directory (directory)
  "Create a directory called DIRECTORY."
  (interactive
   (list (read-file-name "Create directory: " (dired-current-directory))))
  (let ((expanded (directory-file-name (expand-file-name directory))))
    (make-directory expanded)
    (setq dired-last-used-directory (file-name-as-directory expanded))
    (dired-add-file expanded)
    (dired-move-to-filename)))

(defun dired-add-entry (filename &optional marker-char)
  ;; Add a new entry for FILENAME, optionally marking it
  ;; with MARKER-CHAR (a character, else dired-marker-char is used).
  ;; Note that this adds the entry `out of order' if files sorted by
  ;; time, etc.
  ;; At least this version inserts in the right subdirectory (if present).
  ;; And it skips "." or ".." (see `dired-trivial-filenames').
  ;; Hidden subdirs are exposed if a file is added there.
  (setq filename (directory-file-name filename))
  ;; Entry is always for files, even if they happen to also be directories
  (let ((opoint (point))
	(cur-dir (dired-current-directory))
	(directory (file-name-directory filename))
	reason)
    (setq filename (file-name-nondirectory filename)
	  reason
	  (catch 'not-found
	    (if (string= directory cur-dir)
		(progn
		  (if (dired-subdir-hidden-p cur-dir)
		      (dired-unhide-subdir))
		  ;; We are already where we should be, except when
		  ;; point is before the subdir line or its total line.
		  (dired-goto-the-right-place filename))
	      ;; else try to find correct place to insert
	      (if (dired-goto-subdir directory)
		  (progn;; unhide if necessary
		    (if (looking-at "\r");; point is at end of subdir line
			(dired-unhide-subdir))
		    ;; found - skip subdir and `total' line
		    ;; and uninteresting files like . and ..
		    ;; This better not moves into the next subdir!
		    (dired-goto-the-right-place filename))
		;; not found
		(throw 'not-found "Subdir not found")))
	    ;; found and point is at The Right Place:
	    (let ((buffer-read-only ())
		  (at-beg (bolp)))
	      (beginning-of-line)
	      (if at-beg
		  (progn
		    (backward-char 1)
		    (insert-char 10 1)))
	      (dired-add-entry-do-indentation marker-char)
	      (dired-ls (dired-make-absolute filename directory)
	                                              ;; don't expand `.' !
			(concat dired-actual-switches "d"))
	      (if at-beg
		  (delete-char 1))
	      (forward-line -1)
	      ;; We want to have the non-directory part, only:
	      (let* ((beg (dired-move-to-filename t)) ; error for strange output
		     (end (dired-move-to-end-of-filename)))
		(setq filename (buffer-substring beg end))
		(delete-region beg end)
		(insert (file-name-nondirectory filename)))
	      (if dired-after-readin-hook;; the subdir-alist is not affected...
		  (save-excursion;; ...so we can run it right now:
		    (save-restriction
		      (beginning-of-line)
		      (narrow-to-region (point) (save-excursion
						  (forward-line 1) (point)))
		      (run-hooks 'dired-after-readin-hook))))
	      (dired-move-to-filename))
	    ;; return nil if all went well
	    nil))
    (if reason				; don't move away on failure
	(goto-char opoint))
    (not reason)))			; return t on succes, nil else

;;  Ridiculous that this should be needed just because someone tries to be
;;  smart and makes string-lessp sort according to LOCALE, which is wrong 
;;  here since ls doesn't care about that. I dont want to think about how
;;  much extra time this might take:
(if (or (getenv "LANG") (getenv "LC_LOCALE"))

    (defun my-string-lessp (str1 str2)
      (let ((maxlen (min (length str1) (length str2)))
	    (i 0))
	(while (and (< i maxlen)
		    (= (string-to-char (substring str1 i)) 
		       (string-to-char (substring str2 i))))
	  (setq i (1+ i)))
	(< (string-to-char (substring str1 i))
	   (string-to-char (substring str2 i)))))

    (fset 'my-string-lessp 'string-lessp))

(defun dired-goto-the-right-place (filename)
  (if (string-match dired-sort-by-name-regexp dired-actual-switches)
      ;;sort in alphabetically
      (let ((max (dired-subdir-max)))
	(goto-char (dired-after-subdir-garbage (dired-current-directory)))
	(while (and (< (point) max) 
		    (my-string-lessp (file-name-nondirectory
				      (or (dired-get-filename nil t) "\377"))
				     filename))
	  (dired-next-file-same-dir)))
    (dired-goto-next-nontrivial-file)))

(defun dired-goto-next-nontrivial-file ()
  ;; Position point on first nontrivial file after point.
  (dired-goto-next-file);; so there is a file to compare with
  (if (stringp dired-trivial-filenames)
      (while (and (not (eobp))
		  (string-match dired-trivial-filenames
				(file-name-nondirectory
				 (or (dired-get-filename nil t) ""))))
	(dired-next-file-same-dir))))

;;  Actually, all the interface to how the buffer looks, and where
;;  to move, should be done through functions like this, to make the
;;  change to alternative formats, as e.g. dired-nstd.el, more
;;  transparent. In that case this could also be done more efficient.
(defun dired-next-file-same-dir ()
  (let ((dir (dired-current-directory))
	(max (dired-subdir-max)))
    (dired-next-line 1)
    (while (and (< (point) max)
		(not (equal (dired-current-directory) dir)))
      (dired-next-line 1))
    (if (not (equal (dired-current-directory) dir))
	(beginning-of-line))))