home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / MouseAndMenuEmacs / dired-dir.el < prev    next >
Encoding:
Text File  |  1990-05-31  |  14.8 KB  |  395 lines
  1. ;;; Additions for Dired to enable directory creation/deletion.
  2. ;;; Russell A. Ritchie, <russell@uk.ac.strath.hci>. Wed Apr 27 15:09:09 1988
  3. ;;; + directory [un]compression.
  4. ;;; George R. S. Weir, <george@uk.ac.strath.hci>. Fri May  6 08:46:04 1988
  5. ;;; + directory purge.
  6. ;;; George R. S. Weir, <george@uk.ac.strath.hci>. Thu May 12 10:16:53 1988
  7. ;;; + directory byte-recompile.
  8. ;;; Russell Ritchie, <russell@uk.ac.strath.hci>. Fri May 13 11:22:49 1988
  9. ;;; + smart grep function.
  10. ;;; Russell Ritchie, <russell@uk.ac.strath.hci>. Fri May 27 10:25:16 1988
  11. ;;; + regexp matching deletion mark function.
  12. ;;; Russell Ritchie, <russell@uk.ac.strath.hci>. Fri May 27 10:59:10 1988
  13. ;;; + symbolic link creation.
  14. ;;; Russell Ritchie, <russell@uk.ac.strath.hci>. Mon Nov  7 15:11:15 1988
  15.  
  16. (require 'dired)            ; Load the standard library.
  17. (provide 'dired-dir)        ; Let the world in general know.
  18.  
  19. ;; Change dired-mode documentation (by redefinition) to reflect added functionality.
  20.  
  21. (defun dired-mode (dirname)
  22.   "Mode for \"editing\" directory listings.
  23. In dired, you are \"editing\" a list of the files in a directory.
  24. You can move using the usual cursor motion commands.
  25. Letters no longer insert themselves.
  26. Instead, type d to flag a file (or directory) for Deletion.
  27. Type u to Unflag a file (remove its D flag).
  28.   Type Rubout to back up one line and unflag.
  29. Type x to eXecute the deletions requested.
  30. Type f to Find the current line's file
  31.   (or Dired it, if it is a directory).
  32. Type o to find file or dired directory in Other window.
  33. Type s to search for files containing something.
  34. Type # to flag temporary files (names beginning with #) for Deletion.
  35. Type ~ to flag backup files (names ending with ~) for Deletion.
  36. Type . to flag numerical backups for Deletion.
  37. Type q to Query for regexp specifying files to flag for Deletion.
  38.   (Spares dired-kept-versions or its numeric argument.)
  39. Type a to flag all temporary (#) and backup (~) files for Deletion.
  40. Type P (purge) to do ``a'' then ``x''.
  41. Type l to make a symbolic link to another file.
  42. Type m to make a new directory.
  43. Type r to rename a file.
  44. Type c to copy a file.
  45. Type v to view a file in View mode, returning to Dired when done.
  46. Type g to read the directory again.  This discards all deletion-flags.
  47. Space and Rubout can be used to move down and up by lines.
  48. Also: C -- compress this file (or directory).  
  49.       U -- uncompress this file (or directory).
  50.       B -- byte compile this file.
  51.  M, G, O -- change file's mode, group or owner.
  52. \\{dired-mode-map}"
  53.   (kill-all-local-variables)    
  54.   (make-local-variable 'revert-buffer-function)
  55.   (setq revert-buffer-function 'dired-revert)
  56.   (setq major-mode 'dired-mode)
  57.   (setq mode-name "Dired")
  58.   (make-local-variable 'dired-directory)
  59.   (setq dired-directory dirname)
  60.   (setq default-directory 
  61.     (if (file-directory-p dirname)
  62.         dirname (file-name-directory dirname)))
  63.   (setq mode-line-buffer-identification (list "Dired: %17b"))
  64.   (setq case-fold-search nil)
  65.   (setq buffer-read-only t)
  66.   (use-local-map dired-mode-map)
  67.   (run-hooks 'dired-mode-hook))
  68.  
  69. ;; Redefine this since we know how to delete directories now.
  70.  
  71. (defun dired-flag-file-deleted (arg)
  72.   "In dired, flag the current line's file for deletion.
  73. With arg, repeat over several lines."
  74.   (interactive "p")
  75.   (dired-repeat-over-lines
  76.     arg
  77.     (function (lambda ()
  78.         (let ((buffer-read-only nil))
  79.           (delete-char 1)
  80.           (insert "D"))))))
  81.  
  82. ;; Redefine this too, since we can delete directories now.
  83.  
  84. (defun dired-do-deletions ()
  85.   "In dired, delete the files flagged for deletion."
  86.   (interactive)
  87.   (let (delete-list answer)
  88.     (save-excursion
  89.       (goto-char 1)
  90.       (while (re-search-forward "^D" nil t)
  91.     (setq delete-list
  92.           (cons (cons (dired-get-filename t) (1- (point)))
  93.             delete-list))))
  94.     (if (null delete-list)
  95.     (message "(No deletions requested)")
  96.       (save-window-excursion
  97.     (switch-to-buffer " *Deletions*")
  98.     (erase-buffer)
  99.     (setq fill-column 70)
  100.     (let ((l (reverse delete-list)))
  101.       ;; Files should be in forward order for this loop.
  102.       (while l
  103.         (if (> (current-column) 59)
  104.         (insert ?\n)
  105.           (or (bobp)
  106.           (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
  107.         (insert (car (car l)))
  108.         (setq l (cdr l))))
  109.     (goto-char (point-min))
  110.     (setq answer (yes-or-no-p "Delete these files? ")))
  111.       (if answer
  112.       (let ((l delete-list)
  113.         failures)
  114.         ;; Files better be in reverse order for this loop!
  115.         ;; That way as changes are made in the buffer
  116.         ;; they do not shift the lines still to be changed.
  117.         (while l
  118.           (goto-char (cdr (car l)))
  119.           (let ((buffer-read-only nil))
  120.         (condition-case ()
  121.             (let ((the-file (concat default-directory (car (car l)))))
  122.               (if (file-directory-p the-file)
  123.               ;; We know how to delete directories now!
  124.               (dired-delete-directory the-file)
  125.             (delete-file the-file))
  126.               (delete-region (point)
  127.                      (progn (forward-line 1) (point))))
  128.           (error (delete-char 1)
  129.              (insert " ")
  130.              (setq failures (cons (car (car l)) failures)))))
  131.           (setq l (cdr l)))
  132.         (if failures
  133.         (message "Deletions failed: %s"
  134.              (prin1-to-string failures))))))))
  135.  
  136.  
  137. ;;; Define the additional features.
  138.  
  139. (defun dired-make-directory (newdir)
  140.   "Make a directory called NEWDIR in the current directory."
  141.   (interactive "sMake directory called: ")
  142.   (let ((full-dirname (expand-file-name newdir)))
  143.     (if (file-exists-p full-dirname)
  144.     (error "%s already exists in %s" newdir default-directory)
  145.       (let ((current-line (1+ (count-lines 1 (point))))) 
  146.     (call-process "mkdir" nil nil nil full-dirname)
  147.     (dired-revert)
  148.     (goto-line current-line)
  149.     (dired-move-to-filename)))))    ; Go to this line's filename.
  150.  
  151. (defun dired-empty-directory (dir)
  152.   "Return t if DIR is empty, i.e. (directory-files DIRNAME) => '(\".\" \"..\")."
  153.   (equal (directory-files dir) (list "." "..")))
  154.  
  155. (defun dired-delete-directory (&optional dirname)
  156.   "Delete directory on this line or supplied (expanded!) optional arg DIRNAME."
  157.   (interactive)
  158.   (let ((dirname (or dirname (dired-get-filename))))
  159.     (if (cond
  160.       ((not (file-directory-p dirname))
  161.        (message "%s is not a directory." dirname))
  162.       ((string= (file-name-nondirectory dirname) "..")
  163.        (message "Cannot delete parent directory."))
  164.       ((string= (file-name-nondirectory dirname) ".")
  165.        (message "Cannot delete current directory."))
  166.       ((not
  167.         (or (dired-empty-directory dirname)
  168.         (yes-or-no-p
  169.          (format "%s is not empty, delete anyway? " dirname))))
  170.        (message "%s is not empty." dirname))
  171.       (t (call-process "rm" nil nil nil "-r" dirname)
  172.          nil))            ; Make certain success returns NIL. 
  173.     ;; Message always returns a string (strings are non-nil).
  174.     (progn 
  175.       (sit-for 1)            ; Let the reason be read.
  176.       (error)))))            ; Let dired-do-deletions know we bombed.
  177.  
  178. ;; Bind the directory creation function to "m".
  179. (define-key dired-mode-map "m" 'dired-make-directory)
  180.  
  181. ;; Since we can now delete and make directories, it would be nice to
  182. ;; be able to copy them too... 
  183.  
  184. (defun dired-copy-file (to-file &optional overwrite)
  185.   "Copy this file (or directory) to TO-FILE, if optional prefix arg
  186. OVERWRITE is t, and TO-FILE is an existing directory prompt for
  187. decision about whether to overwrite it rather than putting this file
  188. or directory in it. If OVERWRITE is non-nil and not t, overwrite."
  189.   (interactive "FCopy to: \nP")
  190.   (let ((from-file (dired-get-filename)))
  191.     (setq to-file (expand-file-name to-file))
  192.     (if (not (file-directory-p from-file))
  193.     (copy-file from-file to-file)
  194.       (if (and
  195.        (file-exists-p to-file)
  196.        overwrite
  197.        (if (eq overwrite t)
  198.            (yes-or-no-p
  199.         (format "%s already exists, overwrite? " to-file))
  200.          t))
  201.       (dired-delete-directory to-file))
  202.       (call-process "cp" nil nil nil "-r" from-file to-file))
  203.     (dired-add-entry (file-name-directory to-file)
  204.              (file-name-nondirectory to-file))))
  205.  
  206. ;; Similarly, renaming (or moving) should be able to handle directories...
  207.  
  208. (defun dired-rename-file (to-file &optional overwrite)
  209.   "Rename this file (or directory) to TO-FILE, if optional prefix arg
  210. OVERWRITE is a number, and TO-FILE is an existing directory prompt for
  211. decision about whether to overwrite it rather than putting this file
  212. or directory in it. If OVERWRITE is non-nil and not a number, overwrite."
  213.   (interactive
  214.    (list (read-file-name
  215.       (format "Rename %s to: "
  216.           (file-name-nondirectory (dired-get-filename)))
  217.       nil (dired-get-filename))
  218.      (car current-prefix-arg)))
  219.   (let ((from-file (dired-get-filename)))
  220.     (setq to-file (expand-file-name to-file))
  221.     (if overwrite
  222.     (rename-file from-file to-file overwrite)
  223.       (call-process "mv" nil nil nil from-file to-file))
  224.     (dired-revert)))
  225.  
  226. ;;; Dired extensions to handle compression and uncompression of
  227. ;;; directories
  228. ;;; George R. S. Weir, Scottish HCI Centre, <george@uk.ac.strath.hci>. 
  229. ;;; Fri May  6 08:46:04 1988
  230.  
  231. (defun dired-compress ()
  232.   "Compress the file or directory on the current line of the Dired buffer."
  233.   (interactive)
  234.   (let ((from-file (dired-get-filename)))
  235.     (if (file-directory-p from-file)
  236.     (dired-compressdir from-file)
  237.       (let ((buffer-read-only nil))
  238.     (if (string-match "\\.Z$" from-file)
  239.         (error "%s is already compressed!" from-file)
  240.       (message "Compressing %s..." from-file)
  241.       (call-process "compress" nil nil nil "-f" from-file)
  242.       (message "Compressing %s... done" from-file)
  243.       (dired-redisplay (concat from-file ".Z")))))))
  244.  
  245. (defun dired-compressdir (dir-name)
  246.   "Compress directories from dired.
  247. Asks for confirmation before running 'compressdir' on supplied arg DIR-NAME."
  248.   (let* ((basename (file-name-nondirectory dir-name))
  249.      (print-dir-name (cond ((string= "." basename) "current directory")
  250.                    ((string= ".." basename) "parent directory")
  251.                    (t basename))))
  252.     (if (yes-or-no-p (format "Compress all files in %s? " print-dir-name))
  253.     (progn
  254.       (message "Compressing all files in %s..." print-dir-name)
  255.       (call-process "compressdir" nil nil nil dir-name)
  256.       (message "Compressing all files in %s... done" print-dir-name)
  257.       (dired-revert dir-name)))))
  258.  
  259. (defun dired-uncompress ()
  260.   "Uncompress the file or directory on the current line of the Dired buffer."
  261.   (interactive)
  262.   (let ((from-file (dired-get-filename)))
  263.     (if (file-directory-p from-file)
  264.     (dired-uncompressdir from-file)
  265.       (let ((buffer-read-only nil))
  266.     (if (not (string-match "\\.Z$" from-file))
  267.         (error "%s is not compressed!" from-file)
  268.       (message "Uncompressing %s..." from-file)
  269.       (call-process "uncompress" nil nil nil from-file)
  270.       (message "Uncompressing %s... done" from-file)
  271.       (dired-redisplay (substring from-file 0 -2)))))))
  272.  
  273. (defun dired-uncompressdir (dir-name)
  274.   "Uncompress directories from dired.
  275. Asks for confirmation before running 'uncompressdir' on supplied arg DIR-NAME."
  276.   (let* ((basename (file-name-nondirectory dir-name))
  277.      (print-dir-name (cond ((string= "." basename) "current directory")
  278.                    ((string= ".." basename) "parent directory")
  279.                    (t basename))))
  280.     (if (yes-or-no-p (format "Uncompress all files in %s? " print-dir-name))
  281.     (progn
  282.       (message "Uncompressing all files in %s..." print-dir-name)
  283.       (call-process "uncompressdir" nil nil nil dir-name)
  284.       (message "Uncompressing all files in %s... done" print-dir-name)
  285.       (dired-revert dir-name)))))
  286.  
  287. ;; 'dired-purge' function to remove all backup (~) and autosave (#) files
  288. ;; George R. S. Weir, <george@uk.ac.strath.hci>. Thu May 12 10:16:53 1988
  289.  
  290. (defun dired-purge ()
  291.   "Purge (with confirmation) all backup~ and #autosave files in current dir."
  292.   (interactive)
  293.   (dired-flag-backup-and-auto-save-files)
  294.   (dired-do-deletions))
  295.  
  296. ;; Bind dired-purge to "P" and dired-flag-backup-and-auto-save-files to "a".
  297. (define-key dired-mode-map "P" 'dired-purge)
  298. (define-key dired-mode-map "a" 'dired-flag-backup-and-auto-save-files)
  299.  
  300. ;; Redefine dired-byte-recompile to work correctly on directory names.
  301.  
  302. (defun dired-byte-recompile ()
  303.   "Byte recompile this file or directory."
  304.   (interactive)
  305.   (let* ((buffer-read-only nil)
  306.      (from-file (dired-get-filename))
  307.      (to-file (substring from-file 0 -3)))
  308.     (if (file-directory-p from-file)
  309.     (if (yes-or-no-p
  310.          (format "Byte-recompile all .el files in %s? "
  311.              (let ((file-name (file-name-nondirectory from-file)))
  312.                (cond ((string= file-name ".") "current directory")
  313.                  ((string= file-name "..") "parent directory")
  314.                  (t file-name)))))
  315.         (byte-recompile-directory from-file t))
  316.       (if (string-match "\\.el$" from-file) nil
  317.     (error "%s is uncompilable!" from-file))
  318.       (byte-compile-file from-file))))
  319.  
  320. (defun dired-grep ()
  321.   "Prompt for search pattern, and file pattern regexps, 
  322. Check search pattern:
  323.   for non-null, confirm if only whitespace, quote if contains whitespace.
  324. Check file pattern:
  325.   for non-null, confirm if only whitespace.
  326. Proceed if checks succeed and grep for search pattern in file pattern."
  327.   (interactive)
  328.   (let* ((pattern (read-input "Look for what?: "))
  329.      (search-pattern 
  330.       (cond ((string= "" pattern)
  331.          (error "Cannot look for instances of the empty string"))
  332.         ((white-spacep pattern)
  333.          (if (y-or-n-p "Look for instances of white space? ")
  334.              (format "\"%s\"" pattern)
  335.            (error "Quit")))
  336.         ((string-match "[ \t]+" pattern)
  337.          (format "\"%s\"" pattern))
  338.         (t pattern)))
  339.      (files
  340.       (read-input
  341.        (concat "Look for " pattern " in what files? (default is all): ")
  342.        "*"))
  343.      (search-files
  344.       (cond
  345.        ((string= "" files)
  346.         (error
  347.          "Cannot search for %s without files being specified." pattern))
  348.        ((white-spacep files)
  349.         (if (y-or-n-p
  350.          "Does the filename really consist solely of white space? ")
  351.         (format "\"%s\"" files)
  352.           (error "Quit")))
  353.        (t files))))
  354.     (grep (concat search-pattern " " search-files))))
  355.  
  356. ;; Install this on "s" (for Search).
  357. (define-key dired-mode-map "s" 'dired-grep)
  358.  
  359. (defun dired-flag-regexp-files ()
  360.   "Match files containing (prompted for) REGEXP for deletion."
  361.   (interactive)
  362.   (let ((regexp (read-input "Mark files matching REGEXP: ")))
  363.     (cond
  364.      ((string= "" regexp)
  365.       (error "Cannot match files with a null regular expression."))
  366.      ((white-spacep regexp)
  367.       (if (not (y-or-n-p
  368.         "Try to delete files with whitespace in their names? "))
  369.       (error "Quit")))
  370.      (t (dired-map-dired-file-lines
  371.      (function (lambda (x y) (if (string-match regexp x)
  372.                      (dired-flag-file-deleted 1)))))))))
  373.  
  374. ;; Install this on "q" (for Query for regexp).
  375.  
  376. (define-key dired-mode-map "q" 'dired-flag-regexp-files)
  377.  
  378. (defun dired-make-symbolic-link (filename linkname)
  379.   "Make a symbolic link to FILENAME called LINKNAME in the current directory."
  380.   (interactive
  381.    (let* ((file (read-file-name "Make link to which file: " nil nil t))
  382.       (link (read-from-minibuffer
  383.          "Name for link: " (file-name-nondirectory file))))
  384.      (list file link)))
  385.   (let ((current-line (1+ (count-lines 1 (point))))) 
  386.     (condition-case nil
  387.     (make-symbolic-link filename linkname)
  388.       (file-already-exists (error "%s already exists." linkname)))
  389.     (dired-revert)
  390.     (goto-line current-line)
  391.     (dired-move-to-filename)))
  392.  
  393. (define-key dired-mode-map "l" 'dired-make-symbolic-link)
  394.  
  395.