diff options
Diffstat (limited to 'lisp/dired-aux.el')
| -rw-r--r-- | lisp/dired-aux.el | 195 |
1 files changed, 130 insertions, 65 deletions
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index a9443482d63..7e709601468 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -200,9 +200,12 @@ Examples of PREDICATE: (> mtime1 mtime2) - mark newer files (not (= size1 size2)) - mark files with different sizes - (not (string= (nth 8 fa1) (nth 8 fa2))) - mark files with different modes - (not (and (= (nth 2 fa1) (nth 2 fa2)) - mark files with different UID - (= (nth 3 fa1) (nth 3 fa2)))) and GID." + (not (string= (file-attribute-modes fa1) - mark files with different modes + (file-attribute-modes fa2))) + (not (and (= (file-attribute-user-id fa1) - mark files with different UID + (file-attribute-user-id fa2)) + (= (file-attribute-group-id fa1) - and GID. + (file-attribute-group-id fa2))))" (interactive (list (let* ((target-dir (dired-dwim-target-directory)) @@ -269,12 +272,12 @@ condition. Two file items are considered to match if they are equal (eval predicate `((fa1 . ,fa1) (fa2 . ,fa2) - (size1 . ,(nth 7 fa1)) - (size2 . ,(nth 7 fa2)) + (size1 . ,(file-attribute-size fa1)) + (size2 . ,(file-attribute-size fa2)) (mtime1 - . ,(float-time (nth 5 fa1))) + . ,(float-time (file-attribute-modification-time fa1))) (mtime2 - . ,(float-time (nth 5 fa2))) + . ,(float-time (file-attribute-modification-time fa2))) ))))) (setq list (cdr list))) list) @@ -301,18 +304,21 @@ List has a form of (file-name full-file-name (attribute-list))." ;; PROGRAM is the program used to change the attribute. ;; OP-SYMBOL is the type of operation (for use in `dired-mark-pop-up'). ;; ARG describes which files to use, as in `dired-get-marked-files'. - (let* ((files (dired-get-marked-files t arg)) + (let* ((files (dired-get-marked-files t arg nil nil t)) ;; The source of default file attributes is the file at point. (default-file (dired-get-filename t t)) (default (when default-file (cond ((eq op-symbol 'touch) (format-time-string "%Y%m%d%H%M.%S" - (nth 5 (file-attributes default-file)))) + (file-attribute-modification-time + (file-attributes default-file)))) ((eq op-symbol 'chown) - (nth 2 (file-attributes default-file 'string))) + (file-attribute-user-id + (file-attributes default-file 'string))) ((eq op-symbol 'chgrp) - (nth 3 (file-attributes default-file 'string)))))) + (file-attribute-group-id + (file-attributes default-file 'string)))))) (prompt (concat "Change " attribute-name " of %s to" (if (eq op-symbol 'touch) " (default now): " @@ -361,11 +367,11 @@ Symbolic modes like `g+w' are allowed. Type M-n to pull the file attributes of the file at point into the minibuffer." (interactive "P") - (let* ((files (dired-get-marked-files t arg)) + (let* ((files (dired-get-marked-files t arg nil nil t)) ;; The source of default file attributes is the file at point. (default-file (dired-get-filename t t)) (modestr (when default-file - (nth 8 (file-attributes default-file)))) + (file-attribute-modes (file-attributes default-file)))) (default (and (stringp modestr) (string-match "^.\\(...\\)\\(...\\)\\(...\\)$" modestr) @@ -476,7 +482,7 @@ Uses the shell command coming from variables `lpr-command' and `lpr-switches' as default." (interactive "P") (require 'lpr) - (let* ((file-list (dired-get-marked-files t arg)) + (let* ((file-list (dired-get-marked-files t arg nil nil t)) (lpr-switches (if (and (stringp printer-name) (string< "" printer-name)) @@ -668,7 +674,7 @@ In shell syntax this means separating the individual commands with `;'. The output appears in the buffer `*Async Shell Command*'." (interactive - (let ((files (dired-get-marked-files t current-prefix-arg))) + (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list ;; Want to give feedback whether this file or marked files are used: (dired-read-shell-command "& on %s: " current-prefix-arg files) @@ -729,7 +735,7 @@ 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 - (let ((files (dired-get-marked-files t current-prefix-arg))) + (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list ;; Want to give feedback whether this file or marked files are used: (dired-read-shell-command "! on %s: " current-prefix-arg files) @@ -1033,7 +1039,7 @@ Prompt for the archive file name. Choose the archiving command based on the archive file-name extension and `dired-compress-files-alist'." (interactive) - (let* ((in-files (dired-get-marked-files)) + (let* ((in-files (dired-get-marked-files nil nil nil nil t)) (out-file (expand-file-name (read-file-name "Compress to: "))) (rule (cl-find-if (lambda (x) @@ -1156,7 +1162,7 @@ Return nil if no change in files." ;; Pass t for DISTINGUISH-ONE-MARKED so that a single file which ;; is marked pops up a window. That will help the user see ;; it isn't the current line file. - (let ((files (dired-get-marked-files t arg nil t)) + (let ((files (dired-get-marked-files t arg nil t t)) (string (if (eq op-symbol 'compress) "Compress or uncompress" (capitalize (symbol-name op-symbol))))) (dired-mark-pop-up nil op-symbol files #'y-or-n-p @@ -1557,22 +1563,41 @@ Special value `always' suppresses confirmation." (declare-function make-symbolic-link "fileio.c") +(defcustom dired-create-destination-dirs nil + "Whether Dired should create destination dirs when copying/removing files. +If nil, don't create them. +If `always', create them without asking. +If `ask', ask for user confirmation." + :type '(choice (const :tag "Never create non-existent dirs" nil) + (const :tag "Always create non-existent dirs" always) + (const :tag "Ask for user confirmation" ask)) + :group 'dired + :version "27.1") + +(defun dired-maybe-create-dirs (dir) + "Create DIR if doesn't exist according to `dired-create-destination-dirs'." + (when (and dired-create-destination-dirs (not (file-exists-p dir))) + (if (or (eq dired-create-destination-dirs 'always) + (yes-or-no-p (format "Create destination dir `%s'? " dir))) + (dired-create-directory dir)))) + (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) - (when (and (eq t (car (file-attributes from))) + (when (and (eq t (file-attribute-type (file-attributes from))) (file-in-directory-p to from)) (error "Cannot copy `%s' into its subdirectory `%s'" from to)) (let ((attrs (file-attributes from))) (if (and recursive - (eq t (car attrs)) + (eq t (file-attribute-type attrs)) (or (eq recursive 'always) (yes-or-no-p (format "Recursive copies of %s? " from)))) (copy-directory from to preserve-time) (or top (dired-handle-overwrite to)) (condition-case err - (if (stringp (car attrs)) + (if (stringp (file-attribute-type attrs)) ;; It is a symlink - (make-symbolic-link (car attrs) to ok-flag) + (make-symbolic-link (file-attribute-type attrs) to ok-flag) + (dired-maybe-create-dirs (file-name-directory to)) (copy-file from to ok-flag preserve-time)) (file-date-error (push (dired-make-relative from) @@ -1582,6 +1607,7 @@ Special value `always' suppresses confirmation." ;;;###autoload (defun dired-rename-file (file newname ok-if-already-exists) (dired-handle-overwrite newname) + (dired-maybe-create-dirs (file-name-directory newname)) (rename-file file newname ok-if-already-exists) ; error is caught in -create-files ;; Silently rename the visited file of any buffer visiting this file. (and (get-file-buffer file) @@ -1751,7 +1777,7 @@ ESC or `q' to not overwrite any of the remaining files, (setq to destname)) ;; If DESTNAME is a subdirectory of FROM, not a symlink, ;; and the method in use is copying, signal an error. - (and (eq t (car (file-attributes destname))) + (and (eq t (file-attribute-type (file-attributes destname))) (eq file-creator 'dired-copy-file) (file-in-directory-p destname from) (error "Cannot copy `%s' into its subdirectory `%s'" @@ -1834,7 +1860,7 @@ Optional arg HOW-TO determines how to treat the target. arguments for the function that is the first element of the list. For any other return value, TARGET is treated as a directory." (or op1 (setq op1 operation)) - (let* ((fn-list (dired-get-marked-files nil arg)) + (let* ((fn-list (dired-get-marked-files nil arg nil nil t)) (rfn-list (mapcar #'dired-make-relative fn-list)) (dired-one-file ; fluid variable inside dired-create-files (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) @@ -1852,28 +1878,31 @@ Optional arg HOW-TO determines how to treat the target. (dired-mark-read-file-name (concat (if dired-one-file op1 operation) " %s to: ") target-dir op-symbol arg rfn-list default)))) - (into-dir (cond ((null how-to) - ;; Allow users to change the letter case of - ;; a directory on a case-insensitive - ;; filesystem. If we don't test these - ;; conditions up front, file-directory-p - ;; below will return t on a case-insensitive - ;; filesystem, and Emacs will try to move - ;; foo -> foo/foo, which fails. - (if (and (file-name-case-insensitive-p (car fn-list)) - (eq op-symbol 'move) - dired-one-file - (string= (downcase - (expand-file-name (car fn-list))) - (downcase - (expand-file-name target))) - (not (string= - (file-name-nondirectory (car fn-list)) - (file-name-nondirectory target)))) - nil - (file-directory-p target))) - ((eq how-to t) nil) - (t (funcall how-to target))))) + (into-dir + (progn + (unless dired-one-file (dired-maybe-create-dirs target)) + (cond ((null how-to) + ;; Allow users to change the letter case of + ;; a directory on a case-insensitive + ;; filesystem. If we don't test these + ;; conditions up front, file-directory-p + ;; below will return t on a case-insensitive + ;; filesystem, and Emacs will try to move + ;; foo -> foo/foo, which fails. + (if (and (file-name-case-insensitive-p (car fn-list)) + (eq op-symbol 'move) + dired-one-file + (string= (downcase + (expand-file-name (car fn-list))) + (downcase + (expand-file-name target))) + (not (string= + (file-name-nondirectory (car fn-list)) + (file-name-nondirectory target)))) + nil + (file-directory-p target))) + ((eq how-to t) nil) + (t (funcall how-to target)))))) (if (and (consp into-dir) (functionp (car into-dir))) (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) (if (not (or dired-one-file into-dir)) @@ -1972,6 +2001,19 @@ Optional arg HOW-TO determines how to treat the target. dired-dirs))) + +;; We use this function in `dired-create-directory' and +;; `dired-create-empty-file'; the return value is the new entry +;; in the updated Dired buffer. +(defun dired--find-topmost-parent-dir (filename) + "Return the topmost nonexistent parent dir of FILENAME. +FILENAME is a full file name." + (let ((try filename) new) + (while (and try (not (file-exists-p try)) (not (equal new try))) + (setq new try + try (directory-file-name (file-name-directory try)))) + new)) + ;;;###autoload (defun dired-create-directory (directory) "Create a directory called DIRECTORY. @@ -1980,18 +2022,32 @@ If DIRECTORY already exists, signal an error." (interactive (list (read-file-name "Create directory: " (dired-current-directory)))) (let* ((expanded (directory-file-name (expand-file-name directory))) - (try expanded) new) + new) (if (file-exists-p expanded) (error "Cannot create directory %s: file exists" expanded)) - ;; 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)))) + (setq new (dired--find-topmost-parent-dir expanded)) (make-directory expanded t) (when new (dired-add-file new) (dired-move-to-filename)))) +;;;###autoload +(defun dired-create-empty-file (file) + "Create an empty file called FILE. + Add a new entry for the new file in the Dired buffer. + Parent directories of FILE are created as needed. + If FILE already exists, signal an error." + (interactive (list (read-file-name "Create empty file: "))) + (let* ((expanded (expand-file-name file)) + new) + (if (file-exists-p expanded) + (error "Cannot create file %s: file exists" expanded)) + (setq new (dired--find-topmost-parent-dir expanded)) + (make-empty-file file 'parents) + (when new + (dired-add-file new) + (dired-move-to-filename)))) + (defun dired-into-dir-with-symlinks (target) (and (file-directory-p target) (not (file-symlink-p target)))) @@ -2755,7 +2811,9 @@ Intended to be added to `isearch-mode-hook'." "Clean up the Dired file name search after terminating isearch." (define-key isearch-mode-map "\M-sff" nil) (dired-isearch-filenames-mode -1) - (remove-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end t)) + (remove-hook 'isearch-mode-end-hook 'dired-isearch-filenames-end t) + (unless isearch-suspended + (custom-reevaluate-setting 'dired-isearch-filenames))) (defun dired-isearch-filter-filenames (beg end) "Test whether some part of the current search match is inside a file name. @@ -2768,15 +2826,15 @@ is part of a file name (i.e., has the text property `dired-filename')." (defun dired-isearch-filenames () "Search for a string using Isearch only in file names in the Dired buffer." (interactive) - (let ((dired-isearch-filenames t)) - (isearch-forward nil t))) + (setq dired-isearch-filenames t) + (isearch-forward nil t)) ;;;###autoload (defun dired-isearch-filenames-regexp () "Search for a regexp using Isearch only in file names in the Dired buffer." (interactive) - (let ((dired-isearch-filenames t)) - (isearch-forward-regexp nil t))) + (setq dired-isearch-filenames t) + (isearch-forward-regexp nil t)) ;; Functions for searching in tags style among marked files. @@ -2786,14 +2844,14 @@ is part of a file name (i.e., has the text property `dired-filename')." "Search for a string through all marked files using Isearch." (interactive) (multi-isearch-files - (dired-get-marked-files nil nil 'dired-nondirectory-p))) + (dired-get-marked-files nil nil #'dired-nondirectory-p nil t))) ;;;###autoload (defun dired-do-isearch-regexp () "Search for a regexp through all marked files using Isearch." (interactive) (multi-isearch-files-regexp - (dired-get-marked-files nil nil 'dired-nondirectory-p))) + (dired-get-marked-files nil nil 'dired-nondirectory-p nil t))) ;;;###autoload (defun dired-do-search (regexp) @@ -2801,7 +2859,11 @@ is part of a file name (i.e., has the text property `dired-filename')." Stops when a match is found. To continue searching for next match, use command \\[tags-loop-continue]." (interactive "sSearch marked files (regexp): ") - (tags-search regexp '(dired-get-marked-files nil nil 'dired-nondirectory-p))) + (multifile-initialize-search + regexp + (dired-get-marked-files nil nil #'dired-nondirectory-p) + 'default) + (multifile-continue)) ;;;###autoload (defun dired-do-query-replace-regexp (from to &optional delimited) @@ -2814,13 +2876,16 @@ with the command \\[tags-loop-continue]." (query-replace-read-args "Query replace regexp in marked files" t t))) (list (nth 0 common) (nth 1 common) (nth 2 common)))) - (dolist (file (dired-get-marked-files nil nil 'dired-nondirectory-p)) + (dolist (file (dired-get-marked-files nil nil #'dired-nondirectory-p nil t)) (let ((buffer (get-file-buffer file))) (if (and buffer (with-current-buffer buffer buffer-read-only)) (error "File `%s' is visited read-only" file)))) - (tags-query-replace from to delimited - '(dired-get-marked-files nil nil 'dired-nondirectory-p))) + (multifile-initialize-replace + from to (dired-get-marked-files nil nil #'dired-nondirectory-p) + (if (equal from (downcase from)) nil 'default) + delimited) + (multifile-continue)) (declare-function xref--show-xrefs "xref") (declare-function xref-query-replace-in-results "xref") @@ -2837,11 +2902,11 @@ REGEXP should use constructs supported by your local `grep' command." (interactive "sSearch marked files (regexp): ") (require 'grep) (defvar grep-find-ignored-files) - (defvar grep-find-ignored-directories) - (let* ((files (dired-get-marked-files)) + (declare-function rgrep-find-ignored-directories "grep" (dir)) + (let* ((files (dired-get-marked-files nil nil nil nil t)) (ignores (nconc (mapcar (lambda (s) (concat s "/")) - grep-find-ignored-directories) + (rgrep-find-ignored-directories default-directory)) grep-find-ignored-files)) (xrefs (mapcan (lambda (file) |