dired.el

早期freebsd实现

	       (not (eolp))
	       (setq filename (dired-get-filename t t)
		     longfilename (dired-get-filename nil t))
	       (progn (end-of-line)
		      (funcall fn filename longfilename))))
	(forward-line 1)))))

(defun dired-flag-auto-save-files ()
  "Flag for deletion files whose names suggest they are auto save files."
  (interactive)
  (save-excursion
   (let ((buffer-read-only nil))
     (goto-char (point-min))
     (while (not (eobp))
       (and (not (looking-at "  d"))
	    (not (eolp))
	    (if (fboundp 'auto-save-file-name-p)
		(let ((fn (dired-get-filename t t)))
		  (if fn (auto-save-file-name-p fn)))
	      (if (dired-move-to-filename)
		  (looking-at "#")))
	    (progn (beginning-of-line)
		   (delete-char 1)
		   (insert "D")))
       (forward-line 1)))))

(defun dired-clean-directory (keep)
  "Flag numerical backups for Deletion.
Spares dired-kept-versions latest versions, and kept-old-versions oldest.
Positive numeric arg overrides dired-kept-versions;
negative numeric arg overrides kept-old-versions with minus the arg."
  (interactive "P")
  (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions))
  (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
	(late-retention (if (<= keep 0) dired-kept-versions keep))
	(file-version-assoc-list ()))
    ;; Look at each file.
    ;; If the file has numeric backup versions,
    ;; put on file-version-assoc-list an element of the form
    ;; (FILENAME . VERSION-NUMBER-LIST)
    (dired-map-dired-file-lines 'dired-collect-file-versions)
    ;; Sort each VERSION-NUMBER-LIST,
    ;; and remove the versions not to be deleted.
    (let ((fval file-version-assoc-list))
      (while fval
	(let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
	       (v-count (length sorted-v-list)))
	  (if (> v-count (+ early-retention late-retention))
	      (rplacd (nthcdr early-retention sorted-v-list)
		      (nthcdr (- v-count late-retention)
			      sorted-v-list)))
	  (rplacd (car fval)
		  (cdr sorted-v-list)))
	(setq fval (cdr fval)))) 
    ;; Look at each file.  If it is a numeric backup file,
    ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
    (dired-map-dired-file-lines 'dired-trample-file-versions)))

(defun dired-collect-file-versions (ignore fn)
  "If it looks like fn has versions, we make a list of the versions.
We may want to flag some for deletion."
    (let* ((base-versions
	    (concat (file-name-nondirectory fn) ".~"))
	   (bv-length (length base-versions))
	   (possibilities (file-name-all-completions
			   base-versions
			   (file-name-directory fn)))
	   (versions (mapcar 'backup-extract-version possibilities)))
      (if versions
	  (setq file-version-assoc-list (cons (cons fn versions)
					      file-version-assoc-list)))))

(defun dired-trample-file-versions (ignore fn)
  (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
	 base-version-list)
    (and start-vn
	 (setq base-version-list	; there was a base version to which 
	       (assoc (substring fn 0 start-vn)	; this looks like a 
		      file-version-assoc-list))	; subversion
	 (not (memq (string-to-int (substring fn (+ 2 start-vn)))
		    base-version-list))	; this one doesn't make the cut
	 (dired-flag-this-line-for-DEATH))))

(defun dired-flag-this-line-for-DEATH ()
  (beginning-of-line)
  (delete-char 1)
  (insert "D"))

(defun dired-flag-backup-files ()
  "Flag all backup files (names ending with ~) for deletion."
  (interactive)
  (save-excursion
   (let ((buffer-read-only nil))
     (goto-char (point-min))
     (while (not (eobp))
       (and (not (looking-at "  d"))
	    (not (eolp))
	    (if (fboundp 'backup-file-name-p)
		(let ((fn (dired-get-filename t t)))
		  (if fn (backup-file-name-p fn)))
	      (end-of-line)
	      (forward-char -1)
	      (looking-at "~"))
	    (progn (beginning-of-line)
		   (delete-char 1)
		   (insert "D")))
       (forward-line 1)))))

(defun dired-flag-backup-and-auto-save-files ()
  "Flag all backup and temporary files for deletion.
Backup files have names ending in ~.  Auto save file names usually
start with #."
  (interactive)
  (dired-flag-backup-files)
  (dired-flag-auto-save-files))

(defun dired-rename-file (to-file)
  "Rename this file to TO-FILE."
  (interactive
   (list (read-file-name (format "Rename %s to: "
				 (file-name-nondirectory (dired-get-filename)))
			 nil (dired-get-filename))))
  (setq to-file (expand-file-name to-file))
  (rename-file (dired-get-filename) to-file)
  (let ((buffer-read-only nil))
    (beginning-of-line)
    (delete-region (point) (progn (forward-line 1) (point)))
    (setq to-file (expand-file-name to-file))
    (dired-add-entry (file-name-directory to-file)
		     (file-name-nondirectory to-file))))

(defun dired-copy-file (to-file)
  "Copy this file to TO-FILE."
  (interactive "FCopy to: ")
  (copy-file (dired-get-filename) to-file)
  (setq to-file (expand-file-name to-file))
  (dired-add-entry (file-name-directory to-file)
		   (file-name-nondirectory to-file)))

(defun dired-add-entry (directory filename)
  ;; If tree dired is implemented, this function will have to do
  ;; something smarter with the directory.  Currently, just check
  ;; default directory, if same, add the new entry at point.  With tree
  ;; dired, should call 'dired-current-directory' or similar.  Note
  ;; that this adds the entry 'out of order' if files sorted by time,
  ;; etc.
  (if (string-equal directory default-directory)
      (let ((buffer-read-only nil))
	(beginning-of-line)
	(call-process "ls" nil t nil
		      "-d" dired-listing-switches (concat directory filename))
	(forward-line -1)
	(insert "  ")
	(dired-move-to-filename)
	(let* ((beg (point))
	       (end (progn (end-of-line) (point))))
	  (setq filename (buffer-substring beg end))
	  (delete-region beg end)
	  (insert (file-name-nondirectory filename)))
	(beginning-of-line))))

(defun dired-compress ()
  "Compress this file."
  (interactive)
  (let* ((buffer-read-only nil)
	 (error-buffer (get-buffer-create " *Dired compress output*"))
	 (from-file (dired-get-filename))
	 (to-file (concat from-file ".Z")))
    (if (string-match "\\.Z$" from-file)
	(error "%s is already compressed!" from-file))
    (message "Compressing %s..." from-file)
    (unwind-protect
	(progn
	  (save-excursion
	    (set-buffer error-buffer)
	    (erase-buffer))
	  ;; Must have default-directory of dired buffer in call-process
	  (call-process "compress" nil error-buffer nil "-f" from-file)
	  (if (save-excursion
		(set-buffer error-buffer)
		(= 0 (buffer-size)))
	      (progn
		(message "Compressing %s... done" from-file)
		(kill-buffer error-buffer))
	    (display-buffer error-buffer)
	    (setq error-buffer nil)
	    (error "Compress error on %s." from-file)))
      (if error-buffer (kill-buffer error-buffer)))
    (dired-redisplay to-file)))

(defun dired-uncompress ()
  "Uncompress this file."
  (interactive)
  (let* ((buffer-read-only nil)
	 (error-buffer (get-buffer-create " *Dired compress output*"))
	 (from-file (dired-get-filename))
	 (to-file (substring from-file 0 -2)))
    (if (string-match "\\.Z$" from-file) nil
	(error "%s is not compressed!" from-file))
    (message "Uncompressing %s..." from-file)
    (unwind-protect
	(progn
	  (save-excursion
	    (set-buffer error-buffer)
	    (erase-buffer))
	  ;; Must have default-directory of dired buffer in call-process
	  (call-process "uncompress" nil error-buffer nil "-f" from-file)
	  (if (save-excursion
		(set-buffer error-buffer)
		(= 0 (buffer-size)))
	      (progn
		(message "Uncompressing %s... done" from-file)
		(kill-buffer error-buffer))
	    (display-buffer error-buffer)
	    (setq error-buffer nil)
	    (error "Uncompress error on %s." from-file)))
      (if error-buffer (kill-buffer error-buffer)))
    (dired-redisplay to-file)))

(defun dired-byte-recompile ()
  "Byte recompile this file."
  (interactive)
  (let* ((buffer-read-only nil)
	 (from-file (dired-get-filename))
	 (to-file (substring from-file 0 -3)))
    (if (string-match "\\.el$" from-file) nil
	(error "%s is uncompilable!" from-file))
    (byte-compile-file from-file)))

(defun dired-chmod (mode)
  "Change mode of this file."
  (interactive "sChange to Mode: ")
  (let ((buffer-read-only nil)
	(file (dired-get-filename)))
    (call-process "/bin/chmod" nil nil nil mode file)
    (dired-redisplay file)))

(defun dired-chgrp (group)
  "Change group of this file."
  (interactive "sChange to Group: ")
  (let ((buffer-read-only nil)
	(file (dired-get-filename)))
    (call-process "/bin/chgrp" nil nil nil group file)
    (dired-redisplay file)))

(defun dired-chown (owner)
  "Change Owner of this file."
  (interactive "sChange to Owner: ")
  (let ((buffer-read-only nil)
	(file (dired-get-filename)))
    (call-process "/etc/chown" nil nil nil owner file)
    (dired-redisplay file)))

(defun dired-redisplay (file) "Redisplay this line."
  (beginning-of-line)
  (delete-region (point) (progn (forward-line 1) (point)))
  (if file (dired-add-entry (file-name-directory    file)
			    (file-name-nondirectory file)))
  (dired-move-to-filename))

(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 ((fn (concat default-directory (car (car l)))))
		      (if (file-directory-p fn)
			  (progn
			    (call-process "rmdir" nil nil nil fn)
			    (if (file-exists-p fn) (delete-file fn)))
			(delete-file fn))
		      (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))))))))

(provide 'dired)