home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / dired / dired-nstd.el < prev    next >
Encoding:
Text File  |  1992-08-18  |  16.0 KB  |  436 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2. ;;; Jamie Zawinski <jwz@lucid.com> 7-may-91
  3. ;;;
  4. ;;; This makes dired buffers which display multiple directories display
  5. ;;; them in a tree rather than in an "ls -R"-like format.  Which, as every
  6. ;;; Lisp Machine hacker knows, is the Right Thing!
  7. ;;;
  8. ;;;   -rw-r--r--  1 jwz         31543 Mar 26 03:20 reportmail.el
  9. ;;;   -rw-r--r--  1 jwz         14919 Mar 26 03:20 reportmail.elc
  10. ;;;   drwxr-xr-x  2 jwz          1024 Apr  5 13:08 sk-dired/
  11. ;;;     -rw-r--r--  1 jwz          3258 Mar  6 06:33 ange-ftp-dired.el
  12. ;;;     -rw-r--r--  1 jwz          1750 Mar 12 15:04 ange-ftp-dired.elc
  13. ;;;   -rw-r--r--  1 jwz          3151 Mar 29 00:01 symbol-syntax.el
  14. ;;;   -rw-r--r--  1 jwz          1504 Mar 29 01:01 symbol-syntax.elc
  15.  
  16. ;;; This program is free software; you can redistribute it and/or modify
  17. ;;; it under the terms of the GNU General Public License as published by
  18. ;;; the Free Software Foundation; either version 2, or (at your option)
  19. ;;; any later version.
  20. ;;;
  21. ;;; This program is distributed in the hope that it will be useful,
  22. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24. ;;; GNU General Public License for more details.
  25. ;;;
  26. ;;; A copy of the GNU General Public License can be obtained from this
  27. ;;; program's author (send electronic mail to the above address) or from
  28. ;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  
  30. (defconst dired-subdir-alist nil
  31.   "Association list of subdirectories and their buffer positions:
  32.  
  33.   ((LASTDIR STARTMARKER ENDMARKER NESTING-DEPTH)
  34.    ...
  35.    (DEFAULT-DIRECTORY POINTMIN POINTMAX 0)).
  36. "
  37. ;;The markers point right at the end of the line, so that the cursor
  38. ;;looks at either \\n or \\r, the latter for a hidden subdir.
  39. ;; The directories must be file-name-as-directory, of course.
  40. )
  41.  
  42. (defun dired-simple-subdir-alist ()
  43.   ;; Build and return `dired-subdir-alist' assuming just the top level
  44.   ;; directory to be inserted.  Don't parse the buffer.
  45.   (set (make-local-variable 'dired-subdir-alist)
  46.        (list (list default-directory
  47.            (point-min-marker) (point-max-marker) 0))))
  48.  
  49. (define-key dired-mode-map "i" 'dired-insert-subdir-inline)
  50. (define-key dired-mode-map "j" 'dired-maybe-insert-subdir)
  51.  
  52. ;;; ## these should be macros when this is integrated with the distribution.
  53. (defun dired-get-subdir-min (elt) (nth 1 elt))
  54. (defun dired-get-subdir-max (elt) (nth 2 elt))
  55.  
  56. (defun dired-subdir-min ()
  57.   (let ((d (dired-current-directory))
  58.     c)
  59.     (if (setq c (assoc d dired-subdir-alist))
  60.     (marker-position (dired-get-subdir-min c))
  61.       (error "not in a subdir!"))))
  62.  
  63. (defun dired-subdir-max ()
  64.   (let ((d (dired-current-directory))
  65.     c)
  66.     (if (setq c (assoc d dired-subdir-alist))
  67.     (marker-position (dired-get-subdir-max c))
  68.     (point-max))))
  69.  
  70. (defun dired-clear-alist ()
  71.   (while dired-subdir-alist
  72.     (let ((elt (car dired-subdir-alist)))
  73.       (set-marker (nth 1 elt) nil)
  74.       (set-marker (nth 2 elt) nil))
  75.     (setq dired-subdir-alist (cdr dired-subdir-alist))))
  76.  
  77. (defun dired-unsubdir (dir)
  78.   ;; Remove DIR from the alist.
  79.   ;; also remove any directories which are inside of it.
  80.   (let* ((elt (assoc dir dired-subdir-alist))
  81.      (min (nth 1 elt))
  82.      (max (nth 2 elt))
  83.      other-elt
  84.      (rest dired-subdir-alist))
  85.     (while rest
  86.       (setq other-elt (car rest))
  87.       (if (and (<= min (nth 1 other-elt))
  88.            (>= max (nth 2 other-elt)))
  89.       (setq dired-subdir-alist (delq other-elt dired-subdir-alist)))
  90.       (setq rest (cdr rest)))))
  91.  
  92. ;;; this needs to be changed to grok indentation.  Or not. -jwz
  93. ;;; Probably not, as dired-revert either starts with one dir and inserting
  94. ;;; then enlarges the alist automatically, or it inserts all dirs with
  95. ;;; one "ls -lR". -sk
  96. (defun dired-build-subdir-alist ()
  97.   "Build dired-subdir-alist by parsing the buffer and return it's new value."
  98.   (interactive)
  99.   (dired-clear-alist)
  100.   (save-excursion
  101.     (let ((count 0))
  102.       (goto-char (point-min))
  103.       (setq dired-subdir-alist nil)
  104.       (while (re-search-forward dired-subdir-regexp nil t)
  105.     (setq count (1+ count))
  106.     (dired-alist-add (buffer-substring (match-beginning 1)
  107.                        (match-end 1))
  108.              ;; Put subdir boundary between lines:
  109.              (save-excursion
  110.                (goto-char (match-beginning 0))
  111.                (beginning-of-line)
  112.                (point-marker))
  113.              ;; isn't this wrong when already more than one
  114.              ;; subdir is present with -lR?
  115.              ;; maybe.  I don't know.   But we can't call
  116.              ;; dired-subdir-max here, it loops.  -jwz.
  117.              (point-max-marker)
  118.              0)
  119.     (message "%d" count))
  120.       (message "%d director%s." count (if (= 1 count) "y" "ies"))
  121.       ;; return new alist:
  122.       dired-subdir-alist)))
  123.  
  124. (defun dired-alist-add (dir start-marker end-marker indentation-depth)
  125.   ;; indentation-depth may be 0 for more than one directory -- this happens
  126.   ;; when "ls -R" format is used.
  127.   ;; ## debugging code
  128.   (or start-marker (error "start marker nil"))
  129.   (or end-marker (error "end marker nil"))
  130.   ;;(or (/= start-marker end-marker) (error "markers are the same"))
  131.   (let ((old (assoc dir dired-subdir-alist)))
  132.     (setq dired-subdir-alist
  133.       (cons (list (dired-normalize-subdir dir)
  134.               start-marker end-marker
  135.               (or indentation-depth 0))
  136.         (delq old dired-subdir-alist)))
  137.     (dired-alist-sort)))
  138.  
  139. ;; can't see at the moment how this could work with a mixed format
  140. ;; alist -sk
  141. (defun dired-current-directory (&optional relative)
  142.   "Get the subdirectory to which this line belongs.
  143. This returns a string with trailing slash, like default-directory.
  144. Optional argument means return a name relative to default-directory."
  145.   (let (elt
  146.     (here (point))
  147.     (alist (or dired-subdir-alist (dired-build-subdir-alist)))
  148.     best-so-far)
  149.     (while alist
  150.       (setq elt (car alist))
  151.       (if (or (< here (nth 1 elt))
  152.           (> here (nth 2 elt)))
  153.       nil ;; the subdir is disjoint
  154.     ;; otherwise it's on the path between the current file and the root.
  155.     ;; decide if it's deeper than what we've already got.
  156.     (if (or (null best-so-far)
  157.         (< (- (nth 2 elt) (nth 1 elt))
  158.            (- (nth 2 best-so-far) (nth 1 best-so-far))))
  159.         (setq best-so-far elt)))
  160.       (setq alist (cdr alist)))
  161.     (if relative
  162.     (dired-make-relative (car best-so-far) default-directory)
  163.       (car best-so-far))))
  164.  
  165.  
  166. (defun dired-insert-subdir-del (element)
  167.   ;; Erase an already present subdir (given by ELEMENT) from buffer.
  168.   ;; Move to that buffer position.  Return a mark-alist.
  169.   (let ((begin-marker (dired-get-subdir-min element))
  170.     (end-marker (dired-get-subdir-max element)))
  171.     (goto-char end-marker)
  172.     (or (eobp)
  173.     (not (= 0 (nth 3 element)))
  174.     ;; for -R style, want a separating newline _between_ subdirs.
  175.     (forward-char -1))
  176.     (if (= 0 (nth 3 element))
  177.     (insert "\n\n"))
  178.     (prog1
  179.     (dired-remember-marks begin-marker (point))
  180.       (delete-region begin-marker (point)))))
  181.  
  182.  
  183. (defun dired-insert-subdir-doupdate (dirname elt beg-end)
  184.   (let ((beg (nth 0 beg-end))
  185.     (end (nth 1 beg-end))
  186.     (indent (or (nth 2 beg-end) 0)))
  187.     (if (and elt
  188.          (not (eq indent (nth 2 elt))))
  189.     (setq elt nil
  190.           dired-subdir-alist (delq elt dired-subdir-alist)))
  191.     (if elt
  192.     (let ((old-start (nth 1 elt))
  193.           (old-end   (nth 2 elt)))
  194.       (set-marker old-start beg)
  195.       (set-marker old-end end)
  196.       (setcar (nthcdr 3 elt) indent))
  197.       (dired-alist-add dirname
  198.                (set-marker (make-marker) beg)
  199.                (set-marker (make-marker) end)
  200.                indent))))
  201.  
  202. (defun dired-insert-subdir-inline (dirname &optional switches no-error-if-not-dir-p)
  203.   "Insert this subdirectory into the same dired buffer.
  204. If it is already present, overwrites previous entry,
  205.   else inserts it, indented, within its parent's listing.
  206. With a prefix arg, you may edit the ls switches used for this listing.
  207.   This command ignores the `R' switch."
  208.   ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like
  209.   ;; Prospero where dired-ls does the right thing, but
  210.   ;; file-directory-p has not been redefined.
  211.   (interactive
  212.    (list (dired-get-filename)
  213.      (if current-prefix-arg
  214.          (read-string "Switches for listing: " dired-actual-switches))))
  215.   (setq dirname (file-name-as-directory (expand-file-name dirname)))
  216.   (if (let ((case-fold-search nil))
  217.     (string-match "R" (or switches "")))
  218.       (setq switches (concat (substring switches 0 (match-beginning 0))
  219.                  (substring switches (match-end 0)))))
  220.   (dired-make-relative dirname default-directory) ; error on failure
  221.   (or no-error-if-not-dir-p
  222.       (file-directory-p dirname)
  223.       (error  "Attempt to insert a non-directory: %s" dirname))
  224.   (let ((elt (assoc dirname dired-subdir-alist))
  225.     (parentdir (file-name-directory (directory-file-name dirname)))
  226.     beg end old-start old-end new-start new-end
  227.     mark-alist
  228.     tail-adjascents
  229.     buffer-read-only case-fold-search)
  230.     (if elt
  231.     ;; subdir is already present - must first erase it from buffer.
  232.     ;; if it's already in -R format, pretend it wasn't there, but
  233.     ;; remember its file marks.
  234.     (progn
  235.       (setq mark-alist
  236.         (append (dired-insert-subdir-del elt) mark-alist))
  237.       (setq dired-subdir-alist
  238.         (delq elt dired-subdir-alist))))
  239.     ;;(dired-insert-subdir-newpos) ;##
  240.     (dired-goto-file dirname)
  241.     (forward-line 1)
  242.     (dired-insert-subdir-doupdate
  243.      dirname elt (dired-insert-subdir-inline-doinsert dirname switches parentdir))
  244.     (dired-initial-position dirname)
  245.     (save-excursion (dired-mark-remembered mark-alist)))
  246.   (dired-nuke-extra-newlines)
  247.   )
  248.  
  249.  
  250. (defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p)
  251.   "Insert this subdirectory into the same dired buffer.
  252. If it is already present, overwrites previous entry,
  253.   else appends at end of buffer.
  254. With a prefix arg, you may edit the ls switches used for this listing.
  255.   You can add `R' to the switches to expand the whole tree starting at
  256.   this subdirectory.
  257. This function takes some pains to conform to ls -lR output."
  258.   ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like
  259.   ;; Prospero where dired-ls does the right thing, but
  260.   ;; file-directory-p has not been redefined.
  261.   (interactive
  262.    (list (dired-get-filename)
  263.      (if current-prefix-arg
  264.          (read-string "Switches for listing: " dired-actual-switches))))
  265.   (setq dirname (file-name-as-directory (expand-file-name dirname)))
  266.   (dired-make-relative dirname default-directory) ; error on failure
  267.   (or no-error-if-not-dir-p
  268.       (file-directory-p dirname)
  269.       (error  "Attempt to insert a non-directory: %s" dirname))
  270.   (let ((elt (assoc dirname dired-subdir-alist))
  271.     (switches-have-R (and switches (string-match "R" switches)))
  272.     mark-alist
  273.     buffer-read-only case-fold-search)
  274.     (if switches-have-R            ; avoid double subdirs
  275.     (setq mark-alist (dired-kill-tree dirname t)))
  276.     (let ((was-nested (and (nth 3 elt) (not (eq 0 (nth 3 elt))))))
  277.       (if elt                ; subdir is already present
  278.       (setq mark-alist        ; remove it, remembering marks
  279.         (append (dired-insert-subdir-del elt) mark-alist)))
  280.       (if (or was-nested (null elt))
  281.       (dired-insert-subdir-newpos dirname))
  282.       (if was-nested (setcar (nthcdr 3 elt) 0)))
  283.     (dired-insert-subdir-doupdate
  284.      dirname elt (dired-insert-subdir-doinsert dirname switches))
  285.     (if switches-have-R (dired-build-subdir-alist))
  286.     (dired-initial-position dirname)
  287.     (save-excursion (dired-mark-remembered mark-alist)))
  288.   (dired-nuke-extra-newlines))
  289.  
  290. (defun dired-nuke-extra-newlines ()
  291.   (let ((buffer-read-only nil))
  292.     (save-excursion
  293.       (goto-char (point-min))
  294.       (while (re-search-forward "\n\n\n+" nil t)
  295.     (goto-char (+ 2 (match-beginning 0)))
  296.     (delete-region (point) (match-end 0))))))
  297.  
  298.  
  299. (defun dired-insert-subdir-newpos (new-dir)
  300.   ;; Find pos for new subdir, according to tree order.
  301.   ;;(goto-char (point-max))
  302.   (let ((alist dired-subdir-alist) elt dir pos new-pos)
  303.     (while alist
  304.       (setq elt (car alist)
  305.         alist (cdr alist)
  306.         dir (car elt)
  307.         pos (dired-get-subdir-min elt))
  308.       (if (and (= 0 (nth 3 elt)) ; nested ones don't count.
  309.            (dired-tree-lessp dir new-dir))
  310.       ;; Insert NEW-DIR after DIR
  311.       (setq new-pos (dired-get-subdir-max elt)
  312.         alist nil)))
  313.     (goto-char new-pos))
  314.   ;; want a separating newline between subdirs
  315.   (insert "\n\n")
  316.   (point))
  317.  
  318.  
  319. (defvar dired-no-inline-headerlines t
  320.   "*set this to t to suppress the directory header and `total' line.")
  321.  
  322.  
  323. (defun dired-insert-subdir-inline-doinsert (dirname switches parentdir)
  324.   ;; Insert ls output after point and put point on the correct
  325.   ;; position for the subdir alist.
  326.   ;; returns the dired-subdir-alist entry.
  327.   (let ((begin (point)) end
  328.     indent
  329.     tail-adjascents)
  330.     (message "Reading directory %s..." dirname)
  331.     (dired-ls dirname
  332.           (or switches
  333.           (dired-replace-in-string "R" "" dired-actual-switches))
  334.           nil t)
  335.     (message "Reading directory %s...done" dirname)
  336.     (setq end (point))
  337.     (setq indent (1+ (nth 3 (assoc parentdir dired-subdir-alist))))
  338.  
  339.     (save-excursion
  340.       (goto-char begin)
  341.       (or dired-no-inline-headerlines
  342.       (progn
  343.         (dired-insert-headerline dirname)
  344.         (save-excursion (delete-horizontal-space)))
  345.       (goto-char begin)
  346.       (delete-horizontal-space))
  347.       (if (and dired-no-inline-headerlines
  348.            (looking-at "^ *total [0-9]"))
  349.       (progn
  350.         (delete-region (point) (progn (forward-line 1) (point)))
  351.         (setq begin (point)))))
  352.     ;;
  353.     ;; If there are other directories whose end-point is right here,
  354.     ;; then they are the directories such that X is the last directory
  355.     ;; in the listing of Y.  We need to grab them and update their
  356.     ;; last-point to be the same as ours will be (goofy margin-case).
  357.     ;;
  358.     (let ((rest dired-subdir-alist))
  359.       (while rest
  360.     (if (= (point) (nth 2 (car rest)))
  361.         (setq tail-adjascents (cons (car rest) tail-adjascents)))
  362.     (setq rest (cdr rest))))
  363.     (let ((indent-tabs-mode nil))
  364.       (indent-rigidly begin (point) (* 2 (1+ indent))))
  365.     (setq end (point-marker))
  366.     (goto-char begin)
  367.     (while tail-adjascents
  368.       (set-marker (nth 2 (car tail-adjascents)) end)
  369.       (setq tail-adjascents (cdr tail-adjascents)))
  370.     (if dired-after-readin-hook
  371.     (save-restriction
  372.       (narrow-to-region begin end)
  373.       (run-hooks 'dired-after-readin-hook)))
  374.     ;;  call dired-insert-headerline afterwards, as under VMS dired-ls
  375.     ;;  does insert the headerline itself and the insert function just
  376.     ;;  moves point.
  377.     (setq end (prog1 (marker-position end) (set-marker end nil)))
  378.     (goto-char begin)
  379.     (list begin end indent)))
  380.  
  381.  
  382. (defun dired-insert-subdir-doinsert (dirname switches)
  383.   ;; Insert ls output after point and put point on the correct
  384.   ;; position for the subdir alist.
  385.   ;; Return the boundary of the inserted text (as list of BEG and END).
  386.   (let ((begin (point)) end)
  387.     (message "Reading directory %s..." dirname)
  388.     (dired-ls dirname
  389.           (or switches
  390.           (dired-replace-in-string "R" "" dired-actual-switches))
  391.           nil t)
  392.     (message "Reading directory %s...done" dirname)
  393.     (insert "\n\n")
  394.     (setq end (point-marker))
  395.     (indent-rigidly begin (point) 2)
  396.     (if dired-after-readin-hook
  397.     (save-restriction
  398.       (narrow-to-region begin (point))
  399.       (run-hooks 'dired-after-readin-hook)))
  400.     ;;  call dired-insert-headerline afterwards, as under VMS dired-ls
  401.     ;;  does insert the headerline itself and the insert function just
  402.     ;;  moves point.
  403.     (goto-char begin)
  404.     (dired-insert-headerline dirname)
  405.     ;; point is now like in dired-build-subdir-alist
  406.     (setq end (prog1 (marker-position end) (set-marker end nil)))
  407.     (list begin end)))
  408.  
  409.  
  410. (defun dired-insert-old-subdirs (old-subdir-alist)
  411.   ;; Try to insert all subdirs that were displayed before
  412.   (or (string-match "R" dired-actual-switches)
  413.       (let (elt dir)
  414.     (setq old-subdir-alist (sort old-subdir-alist
  415.                      (function (lambda (x y)
  416.                        (< (nth 3 x) (nth 3 y))))))
  417.     (while old-subdir-alist
  418.       (setq elt (car old-subdir-alist)
  419.         old-subdir-alist (cdr old-subdir-alist)
  420.         dir (car elt))
  421.       (condition-case ()
  422.           (if (= 0 (nth 3 elt))
  423.           (dired-insert-subdir dir)
  424.           (dired-insert-subdir-inline dir))
  425.         (error nil))))))
  426.  
  427. (defun dired-add-entry-do-indentation (marker-char)
  428.   ;; two spaces or a marker plus a space, plus nesting indentation.
  429.   ;; Uses fluid vars `directory', `marker-char' from dired-add-entry
  430.   (insert (if marker-char
  431.           (if (integerp marker-char) marker-char dired-marker-char)
  432.         ?\040)
  433.       ?\040)
  434.   (let ((indent (nth 3 (assoc directory dired-subdir-alist))))
  435.     (insert (make-string (* 2 indent) ?\040))))
  436.