;;;-------------- dired support ;;; binding new commands (define-key dired-mode-map "N" 'dired-read-as-man) (define-key dired-mode-map "A" 'dired-archive-directory) (define-key dired-mode-map "E" 'dired-unarchive-directory) (define-key dired-mode-map "h" 'electric-describe-mode) (define-key dired-mode-map "V" 'dired-vm) ;; Redefine this since we know how to delete directories now. (defun dired-flag-file-deleted (arg) "In dired, flag the current line's file for deletion. With arg, repeat over several lines." (interactive "p") (dired-repeat-over-lines arg (function (lambda () (let ((buffer-read-only nil)) (delete-char 1) (insert "D")))))) ;; Redefine this too, since we can delete directories now. (defun dired-do-deletions () "In dired, 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 (dired-get-filename t) (1- (point))) delete-list)))) (if (null delete-list) (message "(No deletions requested)") (save-window-excursion (switch-to-buffer " *Deletions*") (erase-buffer) (setq fill-column 70) (let ((l (reverse delete-list))) ;; Files should be in forward order for this loop. (while l (if (> (current-column) 59) (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 () (let ((the-file (concat default-directory (car (car l))))) (if (file-directory-p the-file) ;; We know how to delete directories now! (dired-delete-directory the-file) (delete-file the-file)) (delete-region (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)))))))) (defvar directory-archive-command "/usr/local/bin/archive" "Name of command (usually a shell script), used to archive a directory. Should take a first parameter, with the name of the directory, and a second one to use a verbose option." ) (defun dired-archive-directory (verbose) "Archives the directory as a .tar.gz file, in the background. The directory is then removed. An argument makes it verbose." (interactive "P") (let* ((dir (file-name-nondirectory (dired-get-filename))) (tarname (concat dir ".tar")) (tarzname (concat tarname ".gz"))) (cond ((not (file-directory-p dir)) (error "Not a directory")) ((not (and (file-writable-p tarname) (file-writable-p tarzname))) (error "Will not be able to write %s or %s . " tarname tarzname))) (if (and (file-exists-p tarname) (not (yes-or-no-p (format "%s exists. Delete it and proceed?" tarname)))) (error "")) (if (and (file-exists-p tarzname) (not (yes-or-no-p (format "%s exists. Delete it and proceed?" tarzname)))) (error "")) (message "Archiving directory %s..." dir) (let* ((process (start-process "a-dired" nil directory-archive-command dir (if verbose " v" ""))) (buf (format "*%s*" (process-name process)))) (set-process-sentinel process 'dired-sentinel) (put 'dired-sentinel (process-name process) (cons (current-buffer) dir)) (if verbose (progn (set-process-buffer process (get-buffer-create buf)) (with-output-to-temp-buffer buf (princ "cd ") (princ default-directory) (terpri) (princ (mapconcat 'identity (process-command process) " ")) (terpri) (terpri)) (save-excursion (set-buffer buf) (fundamental-mode) (setq mode-name "Archiving") (setq mode-line-process '(": %s")))))))) (defvar directory-unarchive-command "/usr/local/bin/unarchive" "Name of command (usually a shell script), used to unarchive a directory. Should take a first parameter, with the name of the directory, and a second one to use a verbose option." ) (defun dired-unarchive-directory (verbose) "Opens a .tar.gz or .tar.Z file, in the background. The directory is then removed. An argument makes it verbose." (interactive "P") (let ((arch (file-name-nondirectory (dired-get-filename)))) (if (not (string-match "\\.tar\\.\\([zZ]\\|gz\\)$" arch)) (error "Not an archive file!") (setq arch (substring arch 0 -6)) (message "Expanding directory %s..." arch) (let* ((process (start-process "e-dired" nil directory-unarchive-command arch (if verbose " v" ""))) (buf (format "*%s*" (process-name process)))) (set-process-sentinel process 'dired-sentinel) (put 'dired-sentinel (process-name process) (cons (current-buffer) arch)) (if verbose (progn (set-process-buffer process (get-buffer-create buf)) (with-output-to-temp-buffer buf (princ "cd ") (princ default-directory) (terpri) (princ (mapconcat 'identity (process-command process) " ")) (terpri) (terpri)) (save-excursion (set-buffer buf) (fundamental-mode) (setq mode-name "Expanding") (setq mode-line-process '(": %s"))))))))) ;; 'dired-purge' function to remove all backup (~) and autosave (#) files ;; George R. S. Weir, . Thu May 12 10:16:53 1988 (defun dired-flag-backup-and-auto-save-files () "Flags ~ and # files for deletion." (dired-flag-backup-files) (dired-flag-auto-save-files)) (defun dired-purge () "Purge (with confirmation) all backup~ and #autosave files in current dir." (interactive) (dired-flag-backup-and-auto-save-files) (dired-do-deletions)) ;; Bind dired-purge to "Q" and dired-flag-backup-and-auto-save-files to "a". (define-key dired-mode-map "Q" 'dired-purge) (define-key dired-mode-map "a" 'dired-flag-backup-and-auto-save-files) ;;;(defvar man-command "(tbl -TX %s | neqn | nroff -h -man | col -x)" ;; SysV (defvar man-command "(tbl -TX %s | neqn | nroff -h -man | col )" "*Format-control string which causes FILE to be processed as by man.") ;; Hint: BS stands form more things than "back space" (defun Manual-nuke-nroff-bs () (interactive "*") ;; Nuke underlining and overstriking (only by the same letter) (goto-char (point-min)) (while (search-forward "\b" nil t) (let* ((preceding (char-after (- (point) 2))) (following (following-char))) (cond ((or (= preceding following) ; x\bx (= preceding ?\_)) ; _\b (delete-char -2)) ((or (= following ?\_) ; \b_ (= following ?\ )) ; \b(SPACE) (delete-region (1- (point)) (1+ (point)))) (t (delete-char -1))))) ; \b by itself (remove it) ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)" (goto-char (point-min)) (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Za-z]+)\\).*\\1$" nil t) (replace-match "")) ;; Nuke footers: "Printed 12/3/85 27 April 1981 1" ;; Sun appear to be on drugz: ;; "Sun Release 3.0B Last change: 1 February 1985 1" ;; HP are even worse! ;; " Hewlett-Packard -1- (printed 12/31/99)" FMHWA12ID!! ;; System V (well WICATs anyway): ;; "Page 1 (printed 7/24/85)" ;; Who is administering PCP to these corporate bozos? (goto-char (point-min)) (while (re-search-forward (cond ((eq system-type 'hpux) "^[ \t]*Hewlett-Packard\\(\\ Company\\)[ \t]*- [0-9]* -.*$") ((eq system-type 'usg-unix-v) "^ *Page [0-9]*.*(printed [0-9/]*)$") (t "^\\(Printed\\Sun Release\\) [0-9].*[0-9]$")) nil t) (replace-match "")) ;; Zap ESC7, ESC8, and ESC9 ;; This is for Sun man pages like "man 1 csh" (goto-char (point-min)) (while (re-search-forward "\e[789]" nil t) (replace-match "")) ;; Crunch blank lines (goto-char (point-min)) (while (re-search-forward "\n\n\n\n*" nil t) (replace-match "\n\n")) ;; Nuke blanks lines at start. (goto-char (point-min)) (skip-chars-forward "\n") (delete-region (point-min) (point))) (defun dired-read-as-man () "Reads the file as a manual-page." (interactive) (require 'man) (let* ((from-file (file-name-nondirectory (dired-get-filename))) (buf (format "*%s - manual*" from-file))) (message "Reading %s..." from-file) (with-output-to-temp-buffer buf (buffer-flush-undo standard-output) (save-excursion (set-buffer standard-output) (message "Processing %s..." from-file) (shell-command (format man-command from-file) t) (message "Cleaning %s..." from-file) (set-buffer buf) (Manual-nuke-nroff-bs) (set-buffer-modified-p nil) (Man-mode)) (message "")))) ;; Mail folders (defvar dired-vm-read-only-folders nil "*If t, \\[dired-vm] will visit all folders read-only. If neither nil nor t, e.g. the symbol `if-file-read-only', only files not writable by you are visited read-only. Read-only folders only work in VM 5, not in VM 4.") (defun dired-vm (&optional read-only) "Run VM on this file. With prefix arg, visit folder read-only (this requires at least VM 5). See also variable `dired-vm-read-only-folders'." (interactive "P") (let ((dir (dired-current-directory)) (fil (dired-get-filename))) ;; take care to supply 2nd arg only if requested - may still run VM 4! (cond (read-only (vm-visit-folder fil t)) ((eq t dired-vm-read-only-folders) (vm-visit-folder fil t)) ((null dired-vm-read-only-folders) (vm-visit-folder fil)) (t (vm-visit-folder fil (not (file-writable-p fil))))) ;; so that pressing `v' inside VM does prompt within current directory: (set (make-local-variable 'vm-folder-directory) dir)))