;;; 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 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>.
;; Maintainer: FSF
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; We need macros in dired.el to compile properly.
(eval-when-compile (require 'dired))
+(defvar dired-create-files-failures nil
+ "Variable where `dired-create-files' records failing file names.
+Functions that operate recursively can store additional names
+into this list; they also should call `dired-log' to log the errors.")
+
;;; 15K
;;;###begin dired-cmd.el
;; Diffing and compressing
\\[set-mark-command], not by Dired's \\[dired-mark] command.)
The prompted-for file is the first file given to `diff'.
With prefix arg, prompt for second argument SWITCHES,
- which is options for `diff'."
+which is options for `diff'."
(interactive
- (let ((default (if (mark t)
+ (let ((current (dired-get-filename t))
+ (default (if (mark t)
(save-excursion (goto-char (mark t))
(dired-get-filename t t)))))
+ (if (or (equal default current)
+ (and (not (equal (dired-dwim-target-directory)
+ (dired-current-directory)))
+ (not mark-active)))
+ (setq default nil))
(require 'diff)
(list (read-file-name (format "Diff %s with%s: "
- (dired-get-filename t)
+ current
(if default
(concat " (default " default ")")
""))
;;;###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-parse-mailcaps "mailcap" (&optional path force))
+(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force))
+(declare-function mailcap-extension-to-mime "mailcap" (extn))
+(declare-function mailcap-mime-info "mailcap"
+ (string &optional request no-decode))
+
+(defun dired-read-shell-command-default (files)
+ "Return a list of default commands for `dired-read-shell-command'."
+ (require 'mailcap)
+ (mailcap-parse-mailcaps)
+ (mailcap-parse-mimetypes)
+ (let* ((all-mime-type
+ ;; All unique MIME types from file extensions
+ (delete-dups (mapcar (lambda (file)
+ (mailcap-extension-to-mime
+ (file-name-extension file t)))
+ files)))
+ (all-mime-info
+ ;; All MIME info lists
+ (delete-dups (mapcar (lambda (mime-type)
+ (mailcap-mime-info mime-type 'all))
+ all-mime-type)))
+ (common-mime-info
+ ;; Intersection of mime-infos from different mime-types;
+ ;; or just the first MIME info for a single MIME type
+ (if (cdr all-mime-info)
+ (delq nil (mapcar (lambda (mi1)
+ (unless (memq nil (mapcar
+ (lambda (mi2)
+ (member mi1 mi2))
+ (cdr all-mime-info)))
+ mi1))
+ (car all-mime-info)))
+ (car all-mime-info)))
+ (commands
+ ;; Command strings from `viewer' field of the MIME info
+ (delq nil (mapcar (lambda (mime-info)
+ (let ((command (cdr (assoc 'viewer mime-info))))
+ (if (stringp command)
+ (replace-regexp-in-string
+ ;; Replace mailcap's `%s' placeholder
+ ;; with dired's `?' placeholder
+ "%s" "?"
+ (replace-regexp-in-string
+ ;; Remove the final filename placeholder
+ "\s*\\('\\)?%s\\1?\s*\\'" "" command nil t)
+ nil t))))
+ common-mime-info))))
+ commands))
+
(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
nil 'shell files
(function read-string)
(format prompt (dired-mark-prompt arg files))
- nil 'shell-command-history))
+ nil 'shell-command-history
+ (dired-read-shell-command-default files)))
;; The in-background argument is only needed in Emacs 18 where
;; shell-command doesn't understand an appended ampersand `&'.
in a subdir.
In a noninteractive call (from Lisp code), you must specify
-the list of file names explicitly with the FILE-LIST argument."
+the list of file names explicitly with the FILE-LIST argument, which
+can be produced by `dired-get-marked-files', for example."
;;Functions dired-run-shell-command and dired-shell-stuff-it do the
;;actual work and can be redefined for customization.
(interactive
;; Return nil for sake of nconc in dired-bunch-files.
nil)
\f
-;; In Emacs 19 this will return program's exit status.
-;; This is a separate function so that ange-ftp can redefine it.
-(defun dired-call-process (program discard &rest arguments)
-; "Run PROGRAM with output to current buffer unless DISCARD is t.
-;Remaining arguments are strings passed as command arguments to PROGRAM."
- ;; Look for a handler for default-directory in case it is a remote file name.
- (let ((handler
- (find-file-name-handler (directory-file-name default-directory)
- 'dired-call-process)))
- (if handler (apply handler 'dired-call-process
- program discard arguments)
- (apply 'call-process program nil (not discard) nil arguments))))
(defun dired-check-process (msg program &rest arguments)
; "Display MSG while running PROGRAM, and check for output.
(set-buffer err-buffer)
(erase-buffer)
(setq default-directory dir ; caller's default-directory
- err (not (eq 0
- (apply (function dired-call-process) program nil arguments))))
+ err (not (eq 0 (apply 'process-file program nil t nil arguments))))
(if err
(progn
(dired-log (concat program " " (prin1-to-string arguments) "\n"))
;;; We don't recognize the file as compressed, so compress it.
;;; Try gzip; if we don't have that, use compress.
(condition-case nil
- (if (not (dired-check-process (concat "Compressing " file)
- "gzip" "-f" file))
- (let ((out-name
- (if (file-exists-p (concat file ".gz"))
- (concat file ".gz")
- (concat file ".z"))))
- ;; Rename the compressed file to NEWNAME
- ;; if it hasn't got that name already.
- (if (and newname (not (equal newname out-name)))
- (progn
- (rename-file out-name newname t)
- newname)
- out-name)))
+ (let ((out-name (concat file ".gz")))
+ (and (or (not (file-exists-p out-name))
+ (y-or-n-p
+ (format "File %s already exists. Really compress? "
+ out-name)))
+ (not (dired-check-process (concat "Compressing " file)
+ "gzip" "-f" file))
+ (or (file-exists-p out-name)
+ (setq out-name (concat file ".z")))
+ ;; Rename the compressed file to NEWNAME
+ ;; if it hasn't got that name already.
+ (if (and newname (not (equal newname out-name)))
+ (progn
+ (rename-file out-name newname t)
+ newname)
+ out-name)))
(file-error
(if (not (dired-check-process (concat "Compressing " file)
"compress" "-f" file))
may have to reset some subdirectory switches after a `dired-undo'.
You can reset all subdirectory switches to the default using
\\<dired-mode-map>\\[dired-reset-subdir-switches].
-See Info node `(emacs-xtra)Subdir switches' for more details."
+See Info node `(emacs)Subdir switches' for more details."
;; Moves point if the next ARG files are redisplayed.
(interactive "P\np")
(if (and test-for-subdir (dired-get-subdir))
;;;###autoload
(defun dired-copy-file (from to ok-flag)
(dired-handle-overwrite to)
- (condition-case ()
- (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t
- dired-recursive-copies)
- (file-date-error (message "Can't set date")
- (sit-for 1))))
+ (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)))
+ (let ((attrs (file-attributes from))
+ dirfailed)
(if (and recursive
(eq t (car attrs))
(or (eq recursive 'always)
(yes-or-no-p (format "Recursive copies of %s? " from))))
;; This is a directory.
- (let ((files (directory-files from nil dired-re-no-dot)))
+ (let ((mode (file-modes from))
+ (files
+ (condition-case err
+ (directory-files from nil dired-re-no-dot)
+ (file-error
+ (push (dired-make-relative from)
+ dired-create-files-failures)
+ (dired-log "Copying error for %s:\n%s\n" from err)
+ (setq dirfailed t)
+ nil))))
(if (eq recursive 'top) (setq recursive 'always)) ; Don't ask any more.
- (if (file-exists-p to)
- (or top (dired-handle-overwrite to))
- (make-directory to))
- (while files
- (dired-copy-file-recursive
- (expand-file-name (car files) from)
- (expand-file-name (car files) to)
- ok-flag preserve-time nil recursive)
- (setq files (cdr files))))
+ (unless dirfailed
+ (if (file-exists-p to)
+ (or top (dired-handle-overwrite to))
+ (condition-case err
+ (progn
+ (make-directory to)
+ (set-file-modes to #o700))
+ (file-error
+ (push (dired-make-relative from)
+ dired-create-files-failures)
+ (setq files nil)
+ (dired-log "Copying error for %s:\n%s\n" from err)))))
+ (dolist (file files)
+ (let ((thisfrom (expand-file-name file from))
+ (thisto (expand-file-name file to)))
+ ;; Catch errors copying within a directory,
+ ;; and report them through the dired log mechanism
+ ;; just as our caller will do for the top level files.
+ (condition-case err
+ (dired-copy-file-recursive
+ thisfrom thisto
+ ok-flag preserve-time nil recursive)
+ (file-error
+ (push (dired-make-relative thisfrom)
+ dired-create-files-failures)
+ (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))
- (if (stringp (car attrs))
- ;; It is a symlink
- (make-symbolic-link (car attrs) to ok-flag)
- (copy-file from to ok-flag dired-copy-preserve-time)))))
+ (condition-case err
+ (if (stringp (car attrs))
+ ;; It is a symlink
+ (make-symbolic-link (car attrs) to ok-flag)
+ (copy-file from to ok-flag dired-copy-preserve-time))
+ (file-date-error
+ (push (dired-make-relative from)
+ dired-create-files-failures)
+ (dired-log "Can't set date on %s:\n%s\n" from err))))))
;;;###autoload
(defun dired-rename-file (file newname ok-if-already-exists)
;; newfile's entry, or t to use the current marker character if the
;; oldfile was marked.
- (let (failures skipped (success-count 0) (total (length fn-list)))
+ (let (dired-create-files-failures failures
+ skipped (success-count 0) (total (length fn-list)))
(let (to overwrite-query
overwrite-backup-query) ; for dired-handle-overwrite
- (mapcar
+ (mapc
(function
(lambda (from)
(setq to (funcall name-constructor from))
(dired-add-file to actual-marker-char))
(file-error ; FILE-CREATOR aborted
(progn
- (setq failures (cons (dired-make-relative from) failures))
+ (push (dired-make-relative from)
+ failures)
(dired-log "%s `%s' to `%s' failed:\n%s\n"
operation from to err))))))))
fn-list))
(cond
+ (dired-create-files-failures
+ (setq failures (nconc failures dired-create-files-failures))
+ (dired-log-summary
+ (format "%s failed for %d file%s in %d requests"
+ operation (length failures)
+ (dired-plural-s (length failures))
+ total)
+ failures))
(failures
(dired-log-summary
(format "%s failed for %d of %d file%s"
- operation (length failures) total
- (dired-plural-s total))
+ operation (length failures)
+ total (dired-plural-s total))
failures))
(skipped
(dired-log-summary
"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)
and new copies of these files are made in that directory
with the same names that the files currently have. The default
suggested for the target directory depends on the value of
-`dired-dwim-target', which see."
+`dired-dwim-target', which see.
+
+This command copies symbolic links by creating new ones,
+like `cp -d'."
(interactive "P")
(let ((dired-recursive-copies dired-recursive-copies))
(dired-do-create-files 'copy (function dired-copy-file)
and new symbolic links are made in that directory
with the same names that the files currently have. The default
suggested for the target directory depends on the value of
-`dired-dwim-target', which see."
+`dired-dwim-target', which see.
+
+For relative symlinks, use \\[dired-do-relsymlink]."
(interactive "P")
(dired-do-create-files 'symlink (function make-symbolic-link)
"Symlink" arg dired-keep-marker-symlink))
may have to reset some subdirectory switches after a `dired-undo'.
You can reset all subdirectory switches to the default using
\\<dired-mode-map>\\[dired-reset-subdir-switches].
-See Info node `(emacs-xtra)Subdir switches' for more details."
+See Info node `(emacs)Subdir switches' for more details."
(interactive
(list (dired-get-filename)
(if current-prefix-arg
(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.