🚀 go-pugleaf

This is my additions to normal dired (NOT tree-dired). See the
discussion in a previous article, or the documentation below for
details.

;;
;;  File: aho-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 put the following in your .emacs :
;;  
;;    (autoload 'dired "aho-dired" () t)
;;    (autoload 'dired-other-window "aho-dired" () t)
;;    (autoload 'dired-noselect "aho-dired" ())
;;
;;
;;  DESCRIPTION
;;
;;  This file implements the following additions to (normal) dired:
;;
;;  * soft links to files in dired, 'l'
;;  * making of directories from dired, 'm'
;;  * printing of files from dired, 'w'
;;  * shell command on a file in dired, '!'
;;  * Copy/Rename/Link needs only the directory name
;;  * Defaulting to last directory used in Copy/Rename/Link
;;  * Uppdating of all dired-buffers at Copy/Rename/Link, and sorting in
;;    alphabetically of new files/links.
;;  * More emphasized tree-structure between the different dired-buffers.
;;    'f' and 'v' climbs (as before) down to a sub-directory, 'q' climbs
;;    up again (after having killed the dired-buffer quietly). (All
;;    dired-buffers in the 'tree' are kept buried, except the current.)
;;  


(require 'dired)

(defun make-directory (fn)
  "Make a directory."
  (if (file-exists-p fn)
      (error "Cannot make directory %s: file already exists" fn)
    (call-process "mkdir" nil nil nil fn))
  (or (file-directory-p fn)
      (error "Could not make directory %s" fn)))

; 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-add-entry (directory filename)
  "If the buffer contains DIRECTORY, add an entry for FILENAME,
inserted alfabetically"
  (if (string-equal directory default-directory)
      (let ((buffer-read-only nil))
	(save-excursion
	  (beginning-of-buffer)
	  (forward-line 1)
	  (while (and (not (eobp)) 
		      (my-string-lessp (dired-get-filename t) filename))
	    (forward-line 1))
	  (call-process "ls" nil t nil
			"-d" dired-listing-switches (concat directory 
			                                    filename))
	  (forward-line -1)
	  (insert "  ")
	  (if (dired-move-to-filename)
	      (let ((beg (point))
		    (end (progn (skip-chars-forward "^ \n") (point))))
		(setq filename (buffer-substring beg end))
		(delete-region beg end)
		(insert (file-name-nondirectory filename)))
	      (let ((beg (progn (beginning-of-line) (point)))
		    (end (progn (forward-line 1) (point))))
		(message (buffer-substring beg (- end 1)))
		(delete-region beg end)
		(ding)))))))

(defun dired-add-to-all (directory filename)
  (let ((buf (current-buffer))
	(blist (buffer-list)))
    (while blist
      (set-buffer (car blist))
      (if (and (eq major-mode 'dired-mode)
	       (equal dired-directory directory))
	  (dired-add-entry directory filename))
      (setq blist (cdr blist)))
    (set-buffer buf)))

(defun default-to-file (to-file)
  (if (file-directory-p to-file)
      (if (equal (file-name-nondirectory to-file) "")
	  (concat to-file (dired-get-filename t))
	  (concat to-file "/" (dired-get-filename t)))
      to-file))

(defun kill-dired-buffer ()
  "Kill dired buffer quietly and switch to invoking buffer if any"
  (interactive)
  (let ((ret-buf father-buffer))
    (kill-buffer (current-buffer))
    (if (and (bufferp ret-buf)
	     (buffer-name ret-buf))
	(if (get-buffer-window ret-buf)
	    (select-window (get-buffer-window ret-buf))
	    (switch-to-buffer ret-buf)))))

(defun dired-link-file (link-name)
  "Make a link to this file named LINK-NAME"
  (interactive 
   (list (read-file-name (format "Name of link to %s : "
				 (dired-get-filename t))
			 last-used-directory)))
  (setq link-name (expand-file-name (default-to-file link-name)))
  (make-symbolic-link (dired-get-filename) link-name)
  (setq last-used-directory (file-name-directory link-name))
  (dired-add-to-all (file-name-directory link-name)
		    (file-name-nondirectory link-name))
  (dired-move-to-filename))

(defun dired-rename-file (to-file)
  "Rename this file to TO-FILE."
  (interactive
   (list (read-file-name (format "Rename %s to: "
				 (dired-get-filename t))
			 last-used-directory)))
  (setq to-file (expand-file-name (default-to-file to-file)))
  (rename-file (dired-get-filename) to-file)
  (setq last-used-directory (file-name-directory to-file))
  (let ((buffer-read-only nil))
    (beginning-of-line)
    (delete-region (point) (progn (forward-line 1) (point)))
    (dired-add-to-all (file-name-directory to-file)
		      (file-name-nondirectory to-file))
    (dired-move-to-filename)))

(defun dired-copy-file (to-file)
  "Copy this file to TO-FILE."
  (interactive 
   (list (read-file-name (format "Copy %s to: "
				 (dired-get-filename t))
			 last-used-directory)))
  (setq to-file (expand-file-name (default-to-file to-file)))
  (copy-file (dired-get-filename) to-file)
  (setq last-used-directory (file-name-directory to-file))
  (dired-add-to-all (file-name-directory to-file)
		    (file-name-nondirectory to-file))
  (dired-move-to-filename))

(defun dired-make-directory (dir-name)
  "Make a subdirectory called DIR-NAME."
  (interactive 
   (list (read-file-name "Name of new directory : " last-used-directory)))
  (setq dir-name (directory-file-name (expand-file-name dir-name)))
  (make-directory dir-name)
  (setq last-used-directory (file-name-as-directory dir-name))
  (dired-add-to-all (file-name-directory dir-name)
		    (file-name-nondirectory dir-name))
  (dired-move-to-filename))

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

(defun dired-view-file ()
  "In dired, examine a file in view mode, returning to dired when done."
  (interactive)
  (if (file-directory-p (dired-get-filename))
      (let ((curr-buf (current-buffer)))
	(dired (dired-get-filename))
	(setq father-buffer curr-buf)
	(bury-buffer curr-buf))
      (view-file (dired-get-filename))))

(defun dired-print-file ()
  "Print this file, using the command in lpr-command and with lpr-switches"
  (interactive)
  (let* ((file (dired-get-filename t))
	 (flags (mapconcat (function identity) lpr-switches " ")))
    (if (y-or-n-p (format "Print %s ? " file))
	(call-process lpr-command nil nil nil flags file))))

(defun dired-shell-command (cmd)
  "Apply COMMAND to this file"
  (interactive "sShell command: ")
  (shell-command (concat cmd " " (dired-get-filename t))))

(defun dired-delete-file-now ()
  "Removes the file on this line immediately (dont use this)"
  (interactive)
  (let ((buffer-read-only nil))
    (beginning-of-line)
    (condition-case ()
	(let ((fn (dired-get-filename)))
	  (if (y-or-n-p (format "Really delete %s now ? " 
				(file-name-nondirectory fn)))
	      (progn
		(if (file-directory-p fn)
		    (call-process "rmdir" nil nil nil fn)
		    (delete-file fn))
		(delete-region (point)
			       (progn (forward-line 1) (point))))))
      (error (delete-char 1)
	     (insert " ")
	     (message "Deletion failed: %s"
		      (dired-get-filename t))))))

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

(define-key dired-mode-map "q" 'kill-dired-buffer)
(define-key dired-mode-map "l" 'dired-link-file)
(define-key dired-mode-map "c" 'dired-copy-file)
(define-key dired-mode-map "r" 'dired-rename-file)
(define-key dired-mode-map "m" 'dired-make-directory)
(define-key dired-mode-map "f" 'dired-find-file)
(define-key dired-mode-map "v" 'dired-view-file)
(define-key dired-mode-map "w" 'dired-print-file)
(define-key dired-mode-map "!" 'dired-shell-command)