NetNews Usenet Archive 1992 #30/NN_1992_30.iso/spool/gnu/emacs/sources/883

Text File | 1992-12-17 | 15.3 KB | 388 lines

Newsgroups: gnu.emacs.sources
Path: sparky!uunet!mcsun!sunic!kth.se!News.kth.se!aho
From: [e-mail] (Anders Holst)
Subject: tree-dired-aho.el
Message-ID: <[e-mail]>
Sender: [e-mail] (Usenet)
Nntp-Posting-Host: thalamus.sans.kth.se
Organization: /home/aho/.organization
Date: Thu, 17 Dec 1992 20:21:18 GMT
Lines: 376

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 ([e-mail])
;;
;;  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))))