;;; dired-aux.el --- less commonly used parts of dired -*-byte-compile-dynamic: t;-*-
;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>.
;; Maintainer: FSF
;;; Code:
-;; We need macros in dired.el to compile properly.
-(eval-when-compile (require 'dired))
+;; We need macros in dired.el to compile properly,
+;; and we call subroutines in it too.
+(require 'dired)
(defvar dired-create-files-failures nil
"Variable where `dired-create-files' records failing file names.
;;;###autoload
(defun dired-do-chmod (&optional arg)
"Change the mode of the marked (or next ARG) files.
-This calls chmod, thus symbolic modes like `g+w' are allowed."
+Symbolic modes like `g+w' are allowed."
(interactive "P")
- (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg))
+ (let* ((files (dired-get-marked-files t arg))
+ (modes (dired-mark-read-string
+ "Change mode of %s to: " nil
+ 'chmod arg files))
+ (num-modes (if (string-match "^[0-7]+" modes)
+ (string-to-number modes 8))))
+ (dolist (file files)
+ (set-file-modes
+ file
+ (if num-modes num-modes
+ (file-modes-symbolic-to-number modes (file-modes file)))))
+ (dired-do-redisplay arg)))
;;;###autoload
(defun dired-do-chgrp (&optional arg)
\f
;;; Shell commands
+(declare-function mailcap-file-default-commands "mailcap" (files))
+
+(defun minibuffer-default-add-dired-shell-commands ()
+ "Return a list of all commands associted with current dired files.
+This function is used to add all related commands retieved by `mailcap'
+to the end of the list of defaults just after the default value."
+ (interactive)
+ (let ((commands (and (boundp 'files) (require 'mailcap nil t)
+ (mailcap-file-default-commands files))))
+ (if (listp minibuffer-default)
+ (append minibuffer-default commands)
+ (cons minibuffer-default commands))))
+
+;; This is an extra function so that you can redefine it, e.g., to use gmhist.
(defun dired-read-shell-command (prompt arg files)
-;; "Read a dired shell command prompting with PROMPT (using read-string).
-;;ARG is the prefix arg and may be used to indicate in the prompt which
-;; files are affected.
-;;This is an extra function so that you can redefine it, e.g., to use gmhist."
- (dired-mark-pop-up
- nil 'shell files
- (function read-string)
- (format prompt (dired-mark-prompt arg files))
- nil 'shell-command-history))
+ "Read a dired shell command prompting with PROMPT (using read-shell-command).
+ARG is the prefix arg and may be used to indicate in the prompt which
+FILES are affected."
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (set (make-local-variable 'minibuffer-default-add-function)
+ 'minibuffer-default-add-dired-shell-commands))
+ (dired-mark-pop-up
+ nil 'shell files
+ #'read-shell-command
+ (format prompt (dired-mark-prompt arg files))
+ nil nil)))
;; The in-background argument is only needed in Emacs 18 where
;; shell-command doesn't understand an appended ampersand `&'.
(other :tag "ask" t))
:group 'dired)
+;; This is a fluid var used in dired-handle-overwrite. It should be
+;; let-bound whenever dired-copy-file etc are called. See
+;; dired-create-files for an example.
(defvar dired-overwrite-confirmed)
(defun dired-handle-overwrite (to)
;; `dired-overwrite-confirmed' and `overwrite-backup-query' are fluid vars
;; from dired-create-files.
(let (backup)
- (if (and dired-backup-overwrite
- dired-overwrite-confirmed
- (setq backup (car (find-backup-file-name to)))
- (or (eq 'always dired-backup-overwrite)
- (dired-query 'overwrite-backup-query
- "Make backup for existing file `%s'? "
- to)))
- (progn
- (rename-file to backup 0) ; confirm overwrite of old backup
- (dired-relist-entry backup)))))
+ (when (and dired-backup-overwrite
+ dired-overwrite-confirmed
+ (setq backup (car (find-backup-file-name to)))
+ (or (eq 'always dired-backup-overwrite)
+ (dired-query 'overwrite-backup-query
+ "Make backup for existing file `%s'? "
+ to)))
+ (rename-file to backup 0) ; confirm overwrite of old backup
+ (dired-relist-entry backup))))
;;;###autoload
(defun dired-copy-file (from to ok-flag)
(dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t
dired-recursive-copies))
+(declare-function make-symbolic-link "fileio.c")
+
(defun dired-copy-file-recursive (from to ok-flag &optional
preserve-time top recursive)
(let ((attrs (file-attributes from))
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive copies of %s? " from))))
;; This is a directory.
- (let ((files
+ (let ((mode (file-modes from))
+ (files
(condition-case err
(directory-files from nil dired-re-no-dot)
(file-error
(if (file-exists-p to)
(or top (dired-handle-overwrite to))
(condition-case err
- (make-directory to)
+ (progn
+ (make-directory to)
+ (set-file-modes to #o700))
(file-error
(push (dired-make-relative from)
dired-create-files-failures)
(file-error
(push (dired-make-relative thisfrom)
dired-create-files-failures)
- (dired-log "Copying error for %s:\n%s\n" thisfrom err))))))
+ (dired-log "Copying error for %s:\n%s\n" thisfrom err)))))
+ (when (file-directory-p to)
+ (set-file-modes to mode)))
;; Not a directory.
(or top (dired-handle-overwrite to))
(condition-case err
skipped (success-count 0) (total (length fn-list)))
(let (to overwrite-query
overwrite-backup-query) ; for dired-handle-overwrite
- (mapcar
- (function
- (lambda (from)
- (setq to (funcall name-constructor from))
- (if (equal to from)
- (progn
- (setq to nil)
- (dired-log "Cannot %s to same file: %s\n"
- (downcase operation) from)))
- (if (not to)
- (setq skipped (cons (dired-make-relative from) skipped))
- (let* ((overwrite (file-exists-p to))
- (dired-overwrite-confirmed ; for dired-handle-overwrite
- (and overwrite
- (let ((help-form '(format "\
+ (dolist (from fn-list)
+ (setq to (funcall name-constructor from))
+ (if (equal to from)
+ (progn
+ (setq to nil)
+ (dired-log "Cannot %s to same file: %s\n"
+ (downcase operation) from)))
+ (if (not to)
+ (setq skipped (cons (dired-make-relative from) skipped))
+ (let* ((overwrite (file-exists-p to))
+ (dired-overwrite-confirmed ; for dired-handle-overwrite
+ (and overwrite
+ (let ((help-form '(format "\
Type SPC or `y' to overwrite file `%s',
DEL or `n' to skip to next,
ESC or `q' to not overwrite any of the remaining files,
`!' to overwrite all remaining files with no more questions." to)))
- (dired-query 'overwrite-query
- "Overwrite `%s'?" to))))
- ;; must determine if FROM is marked before file-creator
- ;; gets a chance to delete it (in case of a move).
- (actual-marker-char
- (cond ((integerp marker-char) marker-char)
- (marker-char (dired-file-marker from)) ; slow
- (t nil))))
- (condition-case err
- (progn
- (funcall file-creator from to dired-overwrite-confirmed)
- (if overwrite
- ;; If we get here, file-creator hasn't been aborted
- ;; and the old entry (if any) has to be deleted
- ;; before adding the new entry.
- (dired-remove-file to))
- (setq success-count (1+ success-count))
- (message "%s: %d of %d" operation success-count total)
- (dired-add-file to actual-marker-char))
- (file-error ; FILE-CREATOR aborted
- (progn
- (push (dired-make-relative from)
- failures)
- (dired-log "%s `%s' to `%s' failed:\n%s\n"
- operation from to err))))))))
- fn-list))
+ (dired-query 'overwrite-query
+ "Overwrite `%s'?" to))))
+ ;; must determine if FROM is marked before file-creator
+ ;; gets a chance to delete it (in case of a move).
+ (actual-marker-char
+ (cond ((integerp marker-char) marker-char)
+ (marker-char (dired-file-marker from)) ; slow
+ (t nil))))
+ (condition-case err
+ (progn
+ (funcall file-creator from to dired-overwrite-confirmed)
+ (if overwrite
+ ;; If we get here, file-creator hasn't been aborted
+ ;; and the old entry (if any) has to be deleted
+ ;; before adding the new entry.
+ (dired-remove-file to))
+ (setq success-count (1+ success-count))
+ (message "%s: %d of %d" operation success-count total)
+ (dired-add-file to actual-marker-char))
+ (file-error ; FILE-CREATOR aborted
+ (progn
+ (push (dired-make-relative from)
+ failures)
+ (dired-log "%s `%s' to `%s' failed:\n%s\n"
+ operation from to err))))))))
(cond
(dired-create-files-failures
(setq failures (nconc failures dired-create-files-failures))
"Create a directory called DIRECTORY."
(interactive
(list (read-file-name "Create directory: " (dired-current-directory))))
- (let ((expanded (directory-file-name (expand-file-name directory))))
- (make-directory expanded)
- (dired-add-file expanded)
- (dired-move-to-filename)))
+ (let* ((expanded (directory-file-name (expand-file-name directory)))
+ (try expanded) new)
+ ;; Find the topmost nonexistent parent dir (variable `new')
+ (while (and try (not (file-exists-p try)) (not (equal new try)))
+ (setq new try
+ try (directory-file-name (file-name-directory try))))
+ (make-directory expanded t)
+ (when new
+ (dired-add-file new)
+ (dired-move-to-filename))))
(defun dired-into-dir-with-symlinks (target)
(and (file-directory-p target)
(defun dired-tree-lessp (dir1 dir2)
;; Lexicographic order on file name components, like `ls -lR':
- ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing,
- ;; i.e., iff DIR1 is a (grand)parent dir of DIR2,
+ ;; DIR1 < DIR2 if DIR1 comes *before* DIR2 in an `ls -lR' listing,
+ ;; i.e., if DIR1 is a (grand)parent dir of DIR2,
;; or DIR1 and DIR2 are in the same parentdir and their last
;; components are string-lessp.
;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp.
(provide 'dired-aux)
-;;; arch-tag: 4b508de9-a153-423d-8d3f-a1bbd86f4f60
+;; arch-tag: 4b508de9-a153-423d-8d3f-a1bbd86f4f60
;;; dired-aux.el ends here
HCoop / bpt / emacs.git / blobdiff