;; dired-fix.el -- corrections to Emacs 20 dired bugs that affect
;; recursive listings.

;; Author: Francis J. Wright <F.J.Wright@maths.qmw.ac.uk>
;; Time-stamp: <28 July 2000>

;; Instal as follows:
;; (add-hook 'dired-load-hook
;;           (lambda () (load "dired-fix")))

(defadvice dired-revert (before dired-revert-advice activate)
  ;; `dired-revert' calls `dired-insert-old-subdirs', which calls
  ;; `dired-insert-subdir', which is defined in `dired-aux.el' without
  ;; an autoload.  `dired-insert-subdir' should either be moved to
  ;; `dired.el' of flagged autoload, to make `dired-revert' behave
  ;; consistently regardless of whether something else has caused
  ;; `dired-aux' to load.
  (require 'dired-aux))

(defadvice dired-sort-other (before dired-sort-other-advice activate)
  ;; Dired takes pains to restore all subdirectories, which makes it
  ;; impossible to undo a recursive listing, so select subdirectories
  ;; to restore carefully!
  (dired-sort-R-check switches))

(make-variable-buffer-local
 (defvar dired-subdir-alist-pre-R nil
   "Value of `dired-subdir-alist' before -R switch added."))

(defun dired-sort-R-check (switches)
  "Additional processing of -R in ls option string SWITCHES.
Saves `dired-subdir-alist' when R is set and restores saved value
minus any directories explicitly deleted when R is cleared.
To be called first in body of `dired-sort-other', etc."
  (cond
   ((and (string-match "R" switches)
	 (not (string-match "R" dired-actual-switches)))
    ;; Adding -R to ls switches -- save `dired-subdir-alist':
    (setq dired-subdir-alist-pre-R dired-subdir-alist))
   ((and (string-match "R" dired-actual-switches)
	 (not (string-match "R" switches)))
    ;; Deleting -R from ls switches -- revert to pre-R subdirs
    ;; that are still present:
    (setq dired-subdir-alist
	  (if dired-subdir-alist-pre-R
	      (let (subdirs)
		(while dired-subdir-alist-pre-R
		  (if (assoc (caar dired-subdir-alist-pre-R)
			     dired-subdir-alist)
		      ;; subdir still present...
		      (setq subdirs
			    (cons (car dired-subdir-alist-pre-R)
				  subdirs)))
		  (setq dired-subdir-alist-pre-R
			(cdr dired-subdir-alist-pre-R)))
		(reverse subdirs))
	    ;; No pre-R subdir alist, so revert to main directory
	    ;; listing:
	    (list (car (reverse dired-subdir-alist))))))))

;; The fixes above are included in Emacs 21.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Fix remote (ftp) recursive listings.  The following function is
;; identical in both Emacs 20.7 and Emacs 21, so this fix should apply
;; equally to both versions.  Make subdirectory headers in recursive
;; listings be the same as those that result from inserting
;; subdirectories explicitly (and prevent Windows from prepending a
;; drive letter).  Perhaps `expand-file-name' should handle this, but
;; it doesn't!

(defadvice dired-build-subdir-alist
  (around dired-build-subdir-alist-advice activate)
  ;; This defadvice is just so that I can turn the fix on and off for
  ;; testing!
  (setq ad-return-value (dired-build-subdir-alist-fix)))

(defun dired-build-subdir-alist-fix ()
  "Build `dired-subdir-alist' by parsing the buffer.
Returns the new value of the alist."
  (interactive)
  (dired-clear-alist)
  (save-excursion
    (let ((count 0)
	  (buffer-read-only nil)
	  new-dir-name
	  (R-ftp-base-dir-regex
	   ;; Used to expand subdirectory names correctly in recursive
	   ;; ang-ftp listings.
	   (and (string-match "R" dired-actual-switches)
		(string-match "\\`/.*:\\(/.*\\)" default-directory)
		(concat "\\`" (match-string 1 default-directory)))))
      (goto-char (point-min))
      (setq dired-subdir-alist nil)
      (while (and (re-search-forward dired-subdir-regexp nil t)
		  ;; Avoid taking a file name ending in a colon
		  ;; as a subdir name.
		  (not (save-excursion
			 (goto-char (match-beginning 0))
			 (beginning-of-line)
			 (forward-char 2)
			 (save-match-data (looking-at dired-re-perms)))))
	(save-excursion
	  (goto-char (match-beginning 1))
	  (setq new-dir-name
		(buffer-substring-no-properties (point) (match-end 1))
		new-dir-name
		(save-match-data
		  (if (and R-ftp-base-dir-regex
			   (not (string= new-dir-name default-directory))
			   (string-match R-ftp-base-dir-regex new-dir-name))
		      (concat default-directory
			      (substring new-dir-name (match-end 0)))
		    (expand-file-name new-dir-name))))
	  (delete-region (point) (match-end 1))
	  (insert new-dir-name))
	(setq count (1+ count))
	(dired-alist-add-1 new-dir-name
			   ;; Place a sub directory boundary between lines.
			   (save-excursion
			     (goto-char (match-beginning 0))
			     (beginning-of-line)
			     (point-marker))))
      (if (> count 1)
	  (message "Buffer includes %d directories" count))
      ;; We don't need to sort it because it is in buffer order per
      ;; constructionem.  Return new alist:
      dired-subdir-alist)))

;;; end of dired-fix.el