From: rmf@chopin.cs.columbia.edu (Robert M. Fuhrer)
Subject: dired extensions
Organization: Computer Science Dept., Columbia Univ.
Distribution: gnu
Date: Mon, 28 Sep 1992 19:24:16 GMT

Here are my dired extensions. Sorry, no docs (but code is commented and
commands have doc strings of course). I believe it should work for others
without modification, but occasionally I forget to include some function I
wrote it depends on... sorry if this happens. I'll be glad to fix it.

-- Bob

;;; =======================================
;;; Dired customizations
;;; =======================================

(require 'cl)

(defun tcomp (t1 t2)
  "Compares TIME1 and TIME2, whose format is as described in file-attributes.
Return 1 if TIME > TIME2, -1 if TIME1 < TIME2, and 0 if equal."
  (cond ((> (car t1) (car t2)) 1)
        ((< (car t1) (car t2)) -1)
        ((> (cadr t1) (cadr t2)) 1)
        ((< (cadr t1) (cadr t2)) -1)
        (t 0)))

(defun elisp-newer-than-bc (file)
  (interactive
   (list (dired-get-filename)))
  (let* ((bcfile (concat file "c"))
        (fattr (file-attributes file))
        (bcattr (file-attributes bcfile)))
    (if (null bcattr)
        (error "No byte code for this file")
      (if (< (tcomp (nth 5 fattr) (nth 5 bcattr)) 0)
          (message "Byte code up to date")
		(error "Byte code newer...recompile")))))


;;; Fix dired-copy-file and dired-rename-file, which don't allow
;;; specifying a directory as the destination.  Also, remember the last
;;; destination and use that as the initial value for the copy-to prompt.

(defvar dired-copy-destination nil "Destination for dired-copy-file")

(defvar dired-diff-destination nil "Destination for dired-diff-file")

(defun dired-alternate-file ()
  "Visits file/directory on this line, and kills the current buffer." 
  (interactive)
  (find-alternate-file (dired-get-filename)))

(defun dired-print-file ()
  "Prints the file on this line via lpr-buffer."
  (interactive)
  (let ((fname (dired-get-filename nil t)) buf)
	(if (or
		 (not fname)
		 (file-directory-p fname))
		(error "No file to print on this line")
	  (message "Printing %s..." fname)
	  (set-buffer (find-file-noselect fname))
	  (lpr-buffer)
	  (kill-buffer (current-buffer))
	  (message "Printing %s...done" fname))))

(defvar dired-backup-extension ".old"
  "File name extension used when making explicit backups in dired.")

(defvar dired-alt-backup-extension "-DIST"
  "Alternate file name extension used when making explicit backups in dired.")

(defun dired-backup-file (backup-name)
  (interactive
   (list (read-string "Backup to: " (concat (dired-get-filename t)
											(if current-prefix-arg
												dired-alt-backup-extension
											  dired-backup-extension)))))
  (copy-file (dired-get-filename t) backup-name)
  (dired-add-entry default-directory (file-name-nondirectory backup-name)))

(defun my-dired-copy-file (to-file overwrite)
  "Copy this file to TO-FILE.
Unlike the original dired-copy-file, allows a directory as the destination,
and uses the last destination (if any) in the prompt.  Optional prefix arg
a minus (as produced by M--) means use the value of dired-diff-destination
as the destination.  Otherwise, if the prefix arg is non-nil, an already
existing file is overwritten without question.
NEEDS A BETTER INTERFACE -- THE PREFIX ARG IS OVERLOADED."
  (interactive 
   (list (read-file-name "Copy to: "
						 (or (and (eq current-prefix-arg '-)
								  (boundp 'dired-diff-destination)
								  dired-diff-destination)
							 (and (boundp 'dired-copy-destination)
								  dired-copy-destination)
							 default-directory))
		 (if current-prefix-arg t 1)))
  (setq dired-copy-destination to-file)
  (let ((fname (dired-get-filename)))
	(if (file-directory-p to-file)
		(setq to-file (concat to-file (file-name-nondirectory fname))))
	;; Check whether source is a directory or file
	(if (file-directory-p fname)
		(shell-command (concat "cp -r " fname " " to-file))
	  (copy-file fname to-file overwrite)
	  (setq to-file (expand-file-name to-file))
	  (dired-add-entry (file-name-directory to-file)
					   (file-name-nondirectory to-file)))))

(defun my-dired-rename-file (to-file)
  "Rename this file to TO-FILE.
Unlike the original version, TO-FILE may be an existing directory,
to which the file is moved.  Also uses the last destination as the prompt."
  (interactive
   (list (read-file-name (format "Rename %s to: "
				 (file-name-nondirectory (dired-get-filename)))
			 (if (boundp 'dired-copy-destination)
			     dired-copy-destination default-directory)
			 nil)))
  (setq dired-copy-destination to-file)
  (let ((fname (dired-get-filename)) (buffer-read-only nil))
    (setq to-file (expand-file-name to-file))
    (if (file-directory-p to-file)
		(setq to-file
			  (concat (if
						  (string= (substring to-file -1) "/")
						  to-file
						(concat to-file "/"))
					  (file-name-nondirectory fname))))
    (rename-file fname to-file)
    (beginning-of-line)
    (delete-region (point) (progn (forward-line 1) (point)))
    (dired-add-entry (file-name-directory to-file)
		     (file-name-nondirectory to-file))))

(defun dired-shell-command-on-file (cmd &optional fmt)
  "Runs a shell command with the file on the current line as the last arg.
With a prefix arg, the command is a format string specifying %s where the
file name is to be inserted."
  (interactive "sCommand: \nP")
  (let ((cmdstr (if fmt (format cmd (dired-get-filename))
				  (concat cmd " " (dired-get-filename)))))
    (message (concat "Running '" cmdstr "'"))
    (shell-command cmdstr)
    (message "Done.")))

(defun dired-flag-backup-this-file ()
  "Flag the emacs backup for the file on the current line for deletion.
If already on the backup, flag this file."
  (interactive)
  (let ((fn (dired-get-filename t t)))
	(if (save-excursion (beginning-of-line) (looking-at "  d"))
		(message "A directory can't have an Emacs backup")
	  (if fn
		  (cond ((char-equal (string-to-char
							  (substring fn -1 (length fn)))
							 ?~)
				 (dired-flag-file-deleted 1))
				(t
				 (save-excursion
				   (goto-char (point-min))
				   (if (re-search-forward (concat " " fn "\\(\\.~[0-9]\\)?~$") (point-max)
										  t)
					   (dired-flag-file-deleted 1)
					 (message "No backup for this file")))))
		(message "No file on this line")))))

(defconst backup-suffix-regexp
  "\\(\\.~[0-9]+\\)?~")

(defun backup-version (backup-fname)
  "Returns the number representing the backup version of backup file FILE."
  (let* ((pos (string-match backup-suffix-regexp backup-fname))
		 (bsuf (substring backup-fname pos)))
	(if (char-equal (string-to-char bsuf) ?~)
		0
	  (string-to-int (substring bsuf 2)))))

(defun backups-of (fname)
  "Returns a list of files in default-directory which are backups for FILE."
  (filter 
   (filter (directory-files default-directory)
		   (function (lambda (fn) (eq 0 (string-match fname fn)))))
   'backup-file-name-p))

(defun latest-backup (fname)
  "Returns the name of the latest backup for FILE."
  (let ((backup-versions (mapcar 'backup-version (backups-of fname))))
	(if (zerop (length backup-versions))
		(error "No backup for %s" fname)
	  (concat fname ".~" (apply 'min backup-versions) "~"))))

(defun dired-diff-backup (backup-fname)
  "Runs diff on this file and its backup.
If on backup, diff the backup and the original version.
Optional prefix argument means ask for name of backup file."
  (interactive
   (list
	(or (and (not current-prefix-arg)
			 (let* ((fn (dired-get-filename))
					(bfn (if (backup-file-name-p fn)
							 (file-name-sans-versions fn)
						   (latest-backup (file-name-nondirectory fn)))))
			   (and (file-exists-p bfn) bfn)))
		(read-file-name "Backup file: "
						(if (and (boundp 'dired-diff-destination)
								 dired-diff-destination)
							dired-diff-destination default-directory)))))
  (setq dired-diff-destination backup-fname)
  (let ((fname (dired-get-filename)) cmdstr)
	(setq cmdstr (concat "diff " fname " " backup-fname))
	(message "diff-ing '%s' with its backup..." (file-name-nondirectory fname))
	(let ((ret (shell-command cmdstr)))
	  (if (stringp ret)
;;; Does shell-command ever return a string != "completed with no output" ?
		  (message "diff finished: files equal")
		(message "diff finished.")))))

(defun dired-make-directory (dirname)
  "Creates a new directory named DIRNAME in the directory being browsed."
  (interactive "FNew directory name: ")
  (if (file-exists-p dirname)
	  (message "File/Directory already exists!")
	(shell-command (concat "mkdir " dirname))
	(dired-revert)))

(defun dired-make-link (pointisnew)
  "Creates a symbolic link for the name under point to PATH.
If prefix arg is non-nil, create link in current directory for PATH."
  (interactive "P")
  (let* ((oldname (if pointisnew (expand-file-name
								  (read-file-name "Old name: "
												  default-directory "" t)))
				  (dired-get-filename))
		 (newname (if pointisnew (concat
								  default-directory
								  (let ((nam (read-string "New name: ")))
									(if (string-equal nam "")
										(file-name-nondirectory oldname)
									  nam)))
					(expand-file-name
					 (read-file-name "New name: " default-directory "" t)))))
	(make-symbolic-link oldname newname)))

(defun dired-hexl-find-file ()
  "Finds the file under point using hexl mode."
  (interactive)
  (hexl-find-file (dired-get-filename)))

(defun dired-eval-for-files-matching (regexp expr &optional query)
  "Evaluates EXPR for each file in the current directory matching REGEXP.
With a non-nil prefix arg, ask before performing the action for each file."
  (interactive "sRegexp: \nxExpr: \nP")
  (setq regexp
		(concat
		 "\\([a-zA-Z]+[ \t]+[ 0-9][0-9][ \t]+[0-9][0-9]:?[0-9][0-9]\\) \\("
		 regexp "\\)$"))
  (save-excursion
	(beginning-of-buffer)
	(let (pt fname)
	  (while (re-search-forward regexp nil t)
		(setq fname (buffer-substring (match-beginning 2) (match-end 2)))
		(if (or (not query)
				(and query (yes-or-no-p (concat fname "? "))))
			(progn
			  (message "Working on '%s'" fname)
			  (setq pt (point))
			  (eval expr)
			  (goto-char pt)))))))

(defvar ftp-target-dir nil "Destination directory for ftp writes.")

(defun dired-ftp-write (host target-dir)
  "Use ftp-write-file to write the file on the current line to HOST."
  (interactive
   (list (setq ftp-host (read-string "Host: "
				     (if (boundp 'ftp-host) ftp-host)))
	 (setq ftp-target-dir (read-string "Directory: "
					   (if (boundp 'ftp-target-dir)
					       ftp-target-dir)))))
  (let* ((source-name (dired-get-filename))
	 (target-name (file-name-nondirectory source-name)))
    (setq target-name (concat ftp-target-dir target-name))
    (set-buffer (find-file-noselect source-name))
    (ftp-write-file host target-name nil nil)))

;;; *****************************************************
;;; * The following provides a "filtered" dired listing *
;;; *****************************************************

(defvar dired-readin-hook
  '(lambda (fname)
	 (or (string-match ".*~" fname)
		 (string-match ".*\\.o" fname)
		 (string-match ".*\\.elc" fname)))
  "File filter hook: should return t if file should NOT be included in list.")

(defun dired-all-but-files (&optional by-suffix)
  "Selects files by suffix to be excluded in a filtered listing.
To actually get the filtered listing, you must then do dired-filtered-readin."
  (interactive "P")
;;; For now, assumes by-suffix is t
  (let (suf suflist)
    (while (not (string= (setq suf (read-string "All But Suffix: ")) ""))
      (setq suflist (cons suf suflist)))
    (setq dired-readin-hook
	  (list 'lambda '(fname)
		(list 'string-match
		      (mapconcat
		       '(lambda (s) (concat "\\(.*\\." s "\\)"))
		       suflist
		       "\\|")
		      'fname)))))

(defun dired-select-files (&optional by-suffix)
  "Selects files by suffix to be included in a filtered listing.
To actually get the filtered listing, you must then do dired-filtered-readin."
  (interactive "P")
;;; For now, assumes by-suffix is t
  (let (suf suflist)
    (while (not (string= (setq suf (read-string "Select Suffix: ")) ""))
      (setq suflist (cons suf suflist)))
    (setq dired-readin-hook
	  (list 'lambda '(fname)
		(list 'not (list 'string-match
		      (mapconcat
		       '(lambda (s) (concat "\\(.*\\." s "\\)"))
		       suflist
		       "\\|")
		      'fname
		))))))

(defun dired-filtered-readin ()
  "Reads the files in the directory visited by this buffer, filtering out files
which have been excluded by either 'dired-all-but-files or dired-select-files."
  (interactive)
  (save-excursion
    (let (dirname (buffer (current-buffer)) (buffer-read-only nil))
      (setq dirname (expand-file-name dired-directory))
	  (message "Reading directory %s..." dirname)
      (widen)
      (erase-buffer)
      (if (file-directory-p dirname)
		  (call-process "ls" nil buffer nil
						dired-listing-switches dirname)
		(let ((default-directory (file-name-directory dirname)))
		  (call-process shell-file-name nil buffer nil
						"-c" (concat "ls " dired-listing-switches " "
									 (file-name-nondirectory dirname)))))
      (goto-char (point-min))
	  (let (fname)
		(while (not (eobp))
		  (if (and dired-readin-hook
				   (setq fname (dired-get-filename t t))
				   (funcall dired-readin-hook fname))
			(kill-line 1)
		  (insert "  ")
		  (forward-line 1))))
	  (goto-char (point-min))
    (message "Reading directory %s...done" dirname))))

(setq dired-file-regexp nil)

(defun dired-maybe-mark-for-execution ()
  (if (string-match dired-file-regexp (dired-get-filename t))
	  (progn (delete-char 1)
			 (insert-char ?X 1))))

(defun dired-mark-files-for-execution ()
  "Marks files by suffix for a subsequent invocation of dired-execute."
  (interactive)
  (let (suf suflist regexp)
    (while (not (string=
				 (setq suf (read-string "Mark file matching regexp: ")) ""))
      (setq suflist (cons suf suflist)))
	(if suflist
		(progn
		  (setq dired-file-regexp (mapconcat 'identity suflist "\\|"))
		  (let ((overwrite-mode t)
				(buffer-read-only nil))
			(beginning-of-buffer)
			(next-line 1)
			(dired-repeat-over-lines (count-lines (point-min) (point-max))
									 'dired-maybe-mark-for-execution))))))

(defvar dired-execute-hook nil)

(defun dired-maybe-execute ()
  (if (looking-at "X")
	  (call-interactively dired-execute-hook)))

(defun dired-execute (keystr)
  (interactive "kCommand [Type dired key sequence] ? ")
  (let ((dirfun (lookup-key dired-mode-map keystr)))
	(setq dired-execute-hook dirfun)
	(beginning-of-buffer)
	(next-line 1)
	(dired-repeat-over-lines (count-lines (point-min) (point-max))
							 'dired-maybe-execute)))

(defun dired-list-by-time ()
  "Produces a listing by modification timestamp of the files in this buffer."
  (interactive)
  (let ((dired-listing-switches "-alt"))
	(revert-buffer)
	(beginning-of-buffer)))

(defun dired-list-by-name ()
  "Produces a listing by name of the files in this buffer."
  (interactive)
  (let ((dired-listing-switches "-al"))
	(revert-buffer)
	(beginning-of-buffer)))

(defun dired-view-file ()
  "Views the file under point in Text-view mode."
  (interactive)
  (find-file (dired-get-filename))
  (text-view-mode))
  
(defun dired-view-file-other-window ()
  "Views the file under point in the other window in Text-view mode."
  (interactive)
  (find-file-other-window (dired-get-filename))
  (text-view-mode))

(defun dired-load-file ()
  "Loads the Emacs Lisp file under point."
  (interactive)
  (load-file (dired-get-filename)))

(autoload 'tar-mode "tar-mode")

(defun dired-visit-tarfile ()
  "Visits the file under point in tar mode."
  (interactive)
  (dired-find-file)
  (tar-mode))
  
(setq dired-mode-hook
      '(lambda ()
	 (define-key dired-mode-map "\C-m" 'dired-next-line)
	 (define-key dired-mode-map "a" 'dired-alternate-file)
	 (define-key dired-mode-map "b" 'dired-backup-file)
	 (define-key dired-mode-map "c" 'my-dired-copy-file)
	 (define-key dired-mode-map "l" 'dired-load-file)
	 (define-key dired-mode-map "m" 'dired-make-directory)
	 (define-key dired-mode-map "r" 'my-dired-rename-file)
	 (define-key dired-mode-map "t" 'dired-visit-tarfile)
;	 (define-key dired-mode-map "v" 'dired-view-file)
	 (define-key dired-mode-map "A" 'dired-all-but-files)
	 (define-key dired-mode-map "D" 'dired-flag-backup-this-file)
	 (define-key dired-mode-map "F" 'dired-filtered-readin)
	 (define-key dired-mode-map "H" 'dired-hexl-find-file)
	 (define-key dired-mode-map "L" 'dired-make-link)
	 (define-key dired-mode-map "N" 'dired-list-by-name)
	 (define-key dired-mode-map "P" 'dired-print-file)
	 (define-key dired-mode-map "R" 'dired-eval-for-files-matching)
	 (define-key dired-mode-map "S" 'dired-select-files)
	 (define-key dired-mode-map "T" 'dired-list-by-time)
;	 (define-key dired-mode-map "V" 'dired-view-file-other-window)
	 (define-key dired-mode-map "W" 'dired-ftp-write)
	 (define-key dired-mode-map "X" 'dired-execute)
	 (define-key dired-mode-map "!" 'dired-shell-command-on-file)
	 (define-key dired-mode-map "^" 'dired-diff-backup)
	 (define-key dired-mode-map "\C-cm" 'dired-mark-files-for-execution)
	 (define-key dired-mode-map "\C-cx" 'dired-execute)
       )
)
--

-- Bob
Newsgroups: gnu.emacs.sources