[comp.emacs] a dired replacement for GNU

tbl@k.cs.cmu.edu.UUCP (03/25/87)

<I came in late...what's all this about a ...line eater?>

Below is Direx.el, my replacement for dired.  Since Direx works without
running ls it should be considerably faster on most systems.  There is a
trade off, however.  By default, direx uses a short style directory
listing.  That is, each file is listed by name only (no size,
protection, owner etc).  To get that extra information you must
explicitly call direx-fake-ls (bound to "l" by default).  

To invoke direx on some directory type M-x direx.  You will be
prompted for the directory name.


Direx mode is a superset of dired mode. In addition to the usual
commands the following exist:

direx-alternate-file : kill the current buffer and find the file
pointed to.  If that file is in fact a directory, then direx it.
This is normally bound to "j".  It is very usefull for bopping up and
down directory trees.

direx-expand-subdirectory : add the contents of a subdirectory to a
direx buffer.  Bound to "s".

direx-fake-ls : use the long listing format.  bound to "l"

There may still be bugs, particularly with features that don't get
much exercize locally (such as direx-clean-directory).  Please mail me
reports of any you find.

If you get to like direx (and I hope you will) you may wish to make
the following bindings:

(global-set-key "\C-x\C-f" 'direx-file)
(global-set-key "\C-x\C-v" 'direx-alternate-file)
(global-set-key "\C-x4f"   'direx-file-other-window)


Have fun!

Thomas Lord
 lord@andrew.cmu.edu			<----- prefered
 tbl@k.cs.cmu.edu

------ cut here and store in direx.el --------

;; DIREX commands for Emacs
;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
;;
;;
;; TODO


;; add sorting : involves changes to direx-show-directory-fast,
;;               direx-add-entry, direx-move-to-file-name 
;;               direx-before-file-name, direx-file-name,
;;               direx-expand-subdirectory, and direx-fake-ls but
;;               should be very straight-forward 
;; add dates to direx-fake-ls :
;;               involves addition of a lisp call to ctime in the 
;;               gnu-emacs c source 
;;
;; add mode changing stuff : very easy.  maybe *i*'ll do it.  
;; add better support for expanding subdirectories in situ...like
;;               maybe getting rid of expandes subdirectories 
;;




(defun name-around-point ()
  "Return the whitespace delimitted text under the point."
  (save-excursion
    (buffer-substring (progn (re-search-backward "[ \t^]")
			     (forward-char 1)
			     (point))
		      (progn (re-search-forward  "[ \t\n%]")
			     (forward-char -1)
			     (point)))))



(defun ensure-slash (path)
  "Make sure that the string PATH ends with a /."
  (let ( (l (length path)) )
    (if (string= "/" (substring path (1- l) l))
	path
	(concat path "/"))))


(defun repeat (n exp)
  "N times, eval EXP.  Repeat once if N is nil."
  (let ( (count (or n 1)) )
    (while (> count 0)
      (eval exp)
      (setq count (1- count)))))


(defvar direx-use-long-directory nil
  "*If this is non-nil, direx mode will always use a long directory format.")

(defvar direx-indicate-directories nil
  "*If non-nil, short direx listings have % after directory names. (Slower)")


(defun direx-show-directory-fast (directory &optional prefix)
  "Insert at the point a brief listing of DIRECTORY."
  (let* ( (buffer-read-only nil)
	  (prefix (or prefix ""))
	  (expanded-name (expand-file-name directory))
	  (attributes    (file-attributes expanded-name)) )
    (cond ( (stringp (car attributes))
	    (direx-show-directory-fast (car attributes)) )
	  ( (not (car attributes))
	    (error "%s is not a directory!" directory) )
	  ( t
	    (or (bolp)
		(insert "\n"))
	    (let ( (start (point))
		   (file-list (directory-files directory nil nil)) )
	      (while file-list
		(let ( (fname (car file-list)) )
		  (insert "  "
			  prefix
			  fname
			  (if (and direx-indicate-directories
				   (file-directory-p fname))
			      "%"
			    "")
			  "\n")
		  (setq file-list (cdr file-list))))
	      (if (or ls-done direx-use-long-directory)
		  (let ( (ls-done nil) )
		    (direx-fake-ls start (1- (point))))))
	    (delete-blank-lines) ))))


(defun direx-add-entry (directory name)
  "  Add an entry for file name if it is in a subdirectory of the
  defualt directory. This will fail if directory is made up of links.
  Right now, we are so lazy that we do not bother to sort."
    (if (= 0 (string-match (expand-file-name default-directory)
		      (expand-file-name directory)))
      (let ( (buffer-read-only nil)
	     (relative-directory
	      (substring directory (match-end 0) (length directory)))
	     (ls-was-done ls-done)
	     (ls-done nil)
	     (start (point)) )
	(if (not (= (point) (point-min)))
	    (insert "\n"))
	(insert "  " relative-directory name)
	(if ls-was-done
	    (direx-fake-ls start (point)))
	(direx-before-file-name))))



(defun direx-move-to-file-name ()
  "Move to the file name field in a direx buffer."
  (end-of-line))

(defun direx-before-file-name ()
  "Move the point before a file name."
  (direx-move-to-file-name)
  (skip-chars-backward "^ \n\t"))

(defun direx-file-name ()
  "Return the name of the file on this line."
  (save-excursion
    (direx-move-to-file-name)
    (let ( (name (name-around-point)) )
      (if (string= name "")
	  (error "No file on this line.")
	name))))

(defun direx-expand-subdirectory ()
  "Insert the subdirectory for the current file in a direx buffer."
  (interactive)
  (direx-move-to-file-name)
  (let ( (buffer-read-only nil)
	 (name  (direx-file-name))
	  (start (point)) )
    (end-of-line 1)
    (direx-show-directory-fast (concat default-directory name)
			       (concat name "/"))
    (goto-char start)
    (direx-next-line)))

(defun direx (directory)
  "Make a buffer for directory and direx in it."
  (interactive "DDirectory: ")
  (let ( (buffer (get-buffer-create
		  (ensure-slash (expand-file-name directory)))) )
    (switch-to-buffer buffer)
    (let ( (buffer-read-only nil) )
      (erase-buffer)
      (setq buffer-read-only t)
      (setq default-directory (ensure-slash (expand-file-name directory)))
      (make-local-variable 'ls-done)
      (setq ls-done nil)
      (direx-show-directory-fast default-directory)
      (goto-char (point-min))
      (direx-before-file-name)
      (direx-mode directory)
      (set-buffer-modified-p nil))
    (setq buffer-read-only t)))


(defun direx-file (file)
  "Find the file FILE unless it is a directory.  If it is a directory,
   direx it."
  (interactive "FFile: ")
  (let ( (attributes (file-attributes file)) )
    (cond ( (eq (car attributes) t)
	    (direx (expand-file-name file)) )
	  ( (car attributes)
	    (direx-file (car attributes)) )
	  ( t
	    (find-file file) ))))
      
(defun direx-alternate-file (file)
  "Visit the file FILE unless it is a directory.  If it is a directory,
   direx it. Kills the current buffer."
  (interactive "FFile: ")
  (let ( (attributes (file-attributes file))
	 (full-name (expand-file-name file)) )
    (cond ( (eq (car attributes) t)
	    (kill-buffer (current-buffer)) 
	    (direx full-name) )
	  ( (car attributes)
	    (direx-alternate-file (car attributes)) )
	  ( t (find-alternate-file file) ))))

(defvar uid-cache '(("-1"."paranoid"))
  "  A cache for argument-value pairs from uid-to-uname.")


(defun password-buffer ()
  "Return the buffer *passwd* which hopefully contains the passwd file."
  (or (get-buffer "*passwd*")
      (save-excursion
	(switch-to-buffer (get-buffer-create "*passwd*"))
	(insert-file "/etc/passwd")
	(current-buffer))))


(defun uid-to-uname (uid)
  "  Convert a user id to a user name.  We assume we can lay claim to a buffer
  named *passwd*."
  (or (cdr (assoc uid uid-cache))
      (let ( (pwbuff (password-buffer)) )
	(save-excursion
	  (switch-to-buffer pwbuff)
	  (goto-char (point-min))
	  (let* ( (uid-string (concat ":" uid ":"))
		  (pwstring  (format "^\\([^:\n]*\\):[^:\n]*%s" uid-string)) )
	    (catch 'no-such-uid
	      (while (not (looking-at pwstring))
		(if (not (search-forward uid-string nil t))
		    (throw 'no-such-uid uid))
		(beginning-of-line))
	      (let ( (uname
		      (buffer-substring (match-beginning 1) (match-end 1))) )
		(setq uid-cache (cons (cons uid uname) uid-cache))
		(bury-buffer (current-buffer))
		uname)))))))


(defun direx-fake-ls (&optional start end)
  "  The current buffer should consist of lines of file names.
   direx-fake-ls makes it look like they were put there by ls -l.
   Optional parameters START and END bound the action of direx-fake-ls"
  (interactive)
  (if ls-done
      nil
    (save-excursion
      (let ( (buffer-read-only nil)
	     (bottom (or end (point-max)))
	     (top (or start (point-min))) )
	(goto-char (1- bottom))
	(while (>= (point) top)
	  (let ( (attributes
		  (or (file-attributes (direx-file-name))
		      '(() -1 -1 () () () () "???" "-barf!-"))) )
	    (beginning-of-line)
	    (if (= (point) top) (setq top (point-max)))
	    (direx-before-file-name)
	    (let ( (access (nth 8 attributes))
		   (links  (concat (nth 1 attributes)))
		   (uid    (concat (nth 2 attributes)))
		   (size   (concat (nth 7 attributes))) )
	      (insert access)
	      (indent-to-column (- 20 (length links)))
	      (insert links " " (uid-to-uname uid))
	      (indent-to-column (- 40 (length size)))
	      (insert size "  ")
	      (direx-previous-line))))
	(setq ls-done t)))
    (direx-before-file-name)))

(defun direx-next-line (&optional count)
  "Move to the file name on the next line.  With ARG, move that many lines."
  (interactive "p")
  (let ( (n (or count 1)) )
    (forward-line n)
    (direx-before-file-name)))

(defun direx-previous-line (&optional count)
  "Move to the file name on the previous line. 
   With ARG, move that many lines."
  (interactive "p")
  (let ( (n (or count 1)) )
    (direx-next-line (- n))))

(defun direx-set-deletion-field (value)
  "Put the char VALUE in the deletion field of the current line.
   Signal an error if there is no file on this line.
   Do nothing if the file on this line is a directory."
  (let* ( (name (direx-file-name))
	  (buffer-read-only nil)
	  (attributes (file-attributes name)) )
    (or (eq (car attributes) t)
      (progn
	(beginning-of-line 1)
	(delete-char 1)
	(insert value)
	(direx-before-file-name)))))


(defun direx-flag-file-deleted (&optional count)
  "Mark a file for deletion."
  (interactive "p")
  (repeat count
	  '(progn
	     (direx-set-deletion-field "D")
	     (direx-next-line))))

(defun direx-unflag (&optional count)
  "Unmark a bunch of files."
  (interactive "p")
  (repeat count
	  '(progn
	     (direx-set-deletion-field " ")
	     (direx-next-line))))

(defun direx-backup-unflag (&optional count)
  "Unmark a bunch of files moving backwards."
  (interactive "p")
  (repeat count
	  '(progn
	     (direx-previous-line)
	     (direx-set-deletion-field " "))))

(defun direx-file-marked-p ()
  "Return t if the current line has a deletion mark."
  (save-excursion
    (beginning-of-line 1)
    (looking-at "D ")))

(defun direx-revert (&optional arg noconfirm)
  "Revert a direx buffer."
  (interactive)
  (let ( (buffer-read-only nil) )
    (erase-buffer)
    (direx-show-directory-fast default-directory)
    (beginning-of-buffer)
    (direx-before-file-name)))


(defun direx-file-other-window (file)
  "Direx FILE in another window."
  (interactive "FFile:")
  (let ( (expanded-name (expand-file-name file)) )
    (other-window 1)
    (direx-file expanded-name)))


(defun direx-view-file (file)
  "Find FILE in view mode.  If FILE is a directory, direx it instead."
  (interactive "fFile: ")
  (let ( (attributes (file-attributes file)) )
    (cond ( (eq (car attributes) t)
	    (direx (expand-file-name file)) )
	  ( (car attributes)
	    (direx-view-file (car-attributes)) )
	  ( t
	    (view-file file) ))))


(defun direx-find-this ()
  "Direx interaction for direx-file."
  (interactive)
  (direx-file (direx-file-name)))

(defun direx-alternate-this ()
  "Direx interaction for direx-alternate-file."
  (interactive)
  (direx-alternate-file (direx-file-name)))

(defun direx-view-this ()
  "Direx interaction for direx-view-file."
  (interactive)
  (direx-view-file (direx-file-name)))

(defun direx-this-other-window ()
  "Direx interaction for direx-file-other-window."
  (interactive)
  (direx-file-other-window (direx-file-name)))

(defun direx-rename-file (to-file)
  "Rename this file to TO-FILE."
  (interactive "FRename to: ")
  (setq to-file (expand-file-name to-file))
  (rename-file (expand-file-name (direx-file-name)) to-file)
  (let ((buffer-read-only nil))
    (beginning-of-line)
    (delete-region (point) (progn (forward-line 1) (point)))
    (end-of-line 0)
    (setq to-file (expand-file-name to-file))
    (direx-add-entry (file-name-directory to-file)
		     (file-name-nondirectory to-file))))

  
(defun direx-do-deletions ()
  "In direx, delete the files flagged for deletion."
  (interactive)
  (let (delete-list answer)
    (save-excursion
     (goto-char 1)
     (while (re-search-forward "^D" nil t)
       (setq delete-list
	     (cons (cons (direx-file-name) (1- (point)))
		   delete-list))))
    (if (null delete-list)
	(message "(No deletions requested)")
      (save-window-excursion
       (switch-to-buffer " *Deletions*")
       (erase-buffer)
       (setq fill-column (- (window-width) 10))
       (let ((l (reverse delete-list)))
	 ;; Files should be in forward order for this loop.
	 (while l
	   (if (> (current-column) (- (window-width) 21))
	       (insert ?\n)
	     (or (bobp)
		 (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
	   (insert (car (car l)))
	   (setq l (cdr l))))
       (goto-char (point-min))
       (setq answer (yes-or-no-p "Delete these files? ")))
      (if answer
	  (let ((l delete-list)
		failures)
	    ;; Files better be in reverse order for this loop!
	    ;; That way as changes are made in the buffer
	    ;; they do not shift the lines still to be changed.
	    (while l
	      (goto-char (cdr (car l)))
	      (let ((buffer-read-only nil))
		(condition-case ()
		    (progn (delete-file (concat default-directory
						(car (car l))))
			   (delete-region (progn (beginning-of-line) (point))
					  (progn (forward-line 1) (point))))
		  (error (delete-char 1)
			 (insert " ")
			 (setq failures (cons (car (car l)) failures)))))
	      (setq l (cdr l)))
	    (if failures
		(message "Deletions failed: %s"
			 (prin1-to-string failures)))
	    (direx-before-file-name))))))


(defun direx-copy-file (to-file)
  "Copy this file to TO-FILE."
  (interactive "FCopy to: ")
  (copy-file (direx-file-name) to-file)
  (setq to-file (expand-file-name to-file))
  (end-of-line)
  (direx-add-entry (file-name-directory to-file)
		   (file-name-nondirectory to-file)))
  

(defun direx-flag-auto-save-files ()
  "Flag for deletion files whose names suggest they are auto save files."
  (interactive)
  (save-excursion
   (let ((buffer-read-only nil))
     (goto-char (point-min))
     (while (not (eobp))
       (and (not (eolp))
	    (if (fboundp 'auto-save-file-name-p)
		(let ((fn (direx-file-name)))
		  (if fn (auto-save-file-name-p fn)))
	      (if (direx-before-filename)
		  (looking-at "#")))
	    (direx-set-deletion-field "D"))
       (forward-line 1)))))


(defun direx-flag-backup-files ()
  "Flag all backup files (names ending with ~) for deletion."
  (interactive)
  (save-excursion
   (let ((buffer-read-only nil))
     (goto-char (point-min))
     (while (not (eobp))
       (and (not (eolp))
	    (if (fboundp 'backup-file-name-p)
		(let ((fn (direx-file-name)))
		  (if fn (backup-file-name-p fn)))
	      (end-of-line)
	      (forward-char -1)
	      (looking-at "~"))
	    (direx-set-deletion-field "D"))
       (forward-line 1)))))


(defconst direx-kept-versions 2
  "*When cleaning directory, number of versions to keep.")

(defun direx-clean-directory (keep)
  "  Flag numerical backups for Deletion.
  Spares dired-kept-versions latest versions, and kept-old-versions oldest.
  Positive numeric arg overrides dired-kept-versions;
  negative numeric arg overrides kept-old-versions with minus the arg."
  (interactive "P")
  (setq keep (if keep (prefix-numeric-value keep) direx-kept-versions))
  (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
	(late-retention (if (<= keep 0) direx-kept-versions keep))
	(file-version-assoc-list ()))
    ;; Look at each file.
    ;; If the file has numeric backup versions,
    ;; put on file-version-assoc-list an element of the form
    ;; (FILENAME . VERSION-NUMBER-LIST)
    (direx-map-direx-file-lines 'direx-collect-file-versions)
    ;; Sort each VERSION-NUMBER-LIST,
    ;; and remove the versions not to be deleted.
    (let ((fval file-version-assoc-list))
      (while fval
	(let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
	       (v-count (length sorted-v-list)))
	  (if (> v-count (+ early-retention late-retention))
	      (rplacd (nthcdr early-retention sorted-v-list)
		      (nthcdr (- v-count late-retention)
			      sorted-v-list)))
	  (rplacd (car fval)
		  (cdr sorted-v-list)))
	(setq fval (cdr fval)))) 
    ;; Look at each file.  If it is a numeric backup file,
    ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
    (direx-map-direx-file-lines 'direx-trample-file-versions)))



(defun direx-collect-file-versions (ignore fn)
  "If it looks like fn has versions, we make a list of the versions.
We may want to flag some for deletion."
    (let* ((base-versions
	    (concat (file-name-nondirectory fn) ".~"))
	   (bv-length (length base-versions))
	   (possibilities (file-name-all-completions
			   base-versions
			   (file-name-directory fn)))
	   (versions (mapcar 'backup-extract-version possibilities)))
      (if versions
	  (setq file-version-assoc-list (cons (cons fn versions)
					      file-version-assoc-list)))))

(defun direx-trample-file-versions (ignore fn)
  (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
	 base-version-list)
    (and start-vn
	 (setq base-version-list	; there was a base version to which 
	       (assoc (substring fn 0 start-vn)	; this looks like a 
		      file-version-assoc-list))	; subversion
	 (not (memq (string-to-int (substring fn (+ 2 start-vn)))
		    base-version-list))	; this one doesn't make the cut
	 (direx-set-deletion-field "D"))))



(defun direx-map-direx-file-lines (fn)
  "perform fn with point at the end of each non-directory line:
arguments are the short and long filename"
  (save-excursion
    (let (filename longfilename (buffer-read-only nil))
      (goto-char (point-min))
      (while (not (eobp))
	(save-excursion
	  (and (not (looking-at "  d"))
	       (not (eolp))
	       (setq filename (direx-get-filename)
		     longfilename (expand-file-name (direx-get-filename)))
	       (progn (end-of-line)
		      (funcall fn filename longfilename))))
	(forward-line 1)))))



(defun direx-summary ()
  "Give the luser a summary of direx commands."
  (interactive)
  (message
   (substitute-command-keys
    "\\[direx-flag-file-deleted] delete, \\[direx-unflag] undelete, \\[direx-do-deletions] execute, \\[direx-find-this] find, \\[direx-alternate-this] jump")))



(defvar direx-mode-map nil "Local keymap for direx-mode buffers.")
(if direx-mode-map
    nil
  (setq direx-mode-map (make-keymap))
  (suppress-keymap direx-mode-map)
  (define-key direx-mode-map " "  'direx-next-line)
  (define-key direx-mode-map "#" 'direx-flag-auto-save-files)
  (define-key direx-mode-map "." 'direx-clean-directory)
  (define-key direx-mode-map "?" 'direx-summary)
  (define-key direx-mode-map "\C-?" 'direx-backup-unflag)
  (define-key direx-mode-map "\C-d" 'direx-flag-file-deleted)
  (define-key direx-mode-map "\C-n" 'direx-next-line)
  (define-key direx-mode-map "\C-p" 'direx-previous-line)
  (define-key direx-mode-map "c" 'direx-copy-file)
  (define-key direx-mode-map "d" 'direx-flag-file-deleted)
  (define-key direx-mode-map "e" 'direx-find-this)
  (define-key direx-mode-map "f" 'direx-find-this)
  (define-key direx-mode-map "g" 'revert-buffer)
  (define-key direx-mode-map "h" 'describe-mode)
  (define-key direx-mode-map "j" 'direx-alternate-this)
  (define-key direx-mode-map "l" 'direx-fake-ls)
  (define-key direx-mode-map "n" 'direx-next-line)
  (define-key direx-mode-map "o" 'direx-this-other-window)
  (define-key direx-mode-map "p" 'direx-previous-line)
  (define-key direx-mode-map "r" 'direx-rename-file)
  (define-key direx-mode-map "s" 'direx-expand-subdirectory)
  (define-key direx-mode-map "u" 'direx-unflag)
  (define-key direx-mode-map "v" 'direx-view-this)
  (define-key direx-mode-map "x" 'direx-do-deletions)
  (define-key direx-mode-map "~" 'direx-flag-backup-files))

;; Direx mode is suitable only for specially formatted data.
(put 'direx-mode 'mode-class 'special)

(defun direx-mode (dirname)
  "Mode for \"editing\" directory listings.
In direx, you are \"editing\" a list of the files in a directory.
You can move using the usual cursor motion commands.
Letters no longer insert themselves.
Instead, type d to flag a file for Deletion.
Type u to Unflag a file (remove its D flag).
  Type Rubout to back up one line and unflag.
Type x to eXecute the deletions requested.
Type l to get a more informative directory listing.
Type f to Find the current line's file
  (or Direx it, if it is a directory).
Type o to find file or direx directory in Other window.
Type # to flag temporary files (names beginning with #) for Deletion.
Type ~ to flag backup files (names ending with ~) for Deletion.
Type . to flag numerical backups for Deletion.
  (Spares direx-kept-versions or its numeric argument.)
Type r to rename a file.
Type c to copy a file.
Type v to view a file in View mode, returning to Direx when done.
Type g to read the directory again.  This discards all deletion-flags.
Type j to direx-find this file in a buffer replacing the current buffer.
Type s to expand a subdirectory in place.
Type l to get a long directory listing for the files in the current buffer.
Space and Rubout can be used to move down and up by lines.
\\{direx-mode-map}"
  (kill-all-local-variables)    
  (make-local-variable 'revert-buffer-function)
  (setq revert-buffer-function 'direx-revert)
  (setq major-mode 'direx-mode)
  (setq mode-name "Direx")
  (make-local-variable 'ls-done)
  (setq default-directory 
	(ensure-slash (expand-file-name (if (file-directory-p dirname)
			      dirname (file-name-directory dirname)))))
  (setq mode-line-buffer-identification '("Direx: %17b"))
  (setq case-fold-search nil)
  (setq buffer-read-only t)
  (use-local-map direx-mode-map)
  (run-hooks 'direx-mode-hook))