1;;; dired-aux.el --- less commonly used parts of dired -*-byte-compile-dynamic: t;-*- 2 3;; Copyright (C) 1985, 1986, 1992, 1994, 1998, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Sebastian Kremer <sk@thp.uni-koeln.de>. 7;; Maintainer: FSF 8;; Keywords: files 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;; The parts of dired mode not normally used. This is a space-saving hack 30;; to avoid having to load a large mode when all that's wanted are a few 31;; functions. 32 33;; Rewritten in 1990/1991 to add tree features, file marking and 34;; sorting by Sebastian Kremer <sk@thp.uni-koeln.de>. 35;; Finished up by rms in 1992. 36 37;;; Code: 38 39;; We need macros in dired.el to compile properly. 40(eval-when-compile (require 'dired)) 41 42(defvar dired-create-files-failures nil 43 "Variable where `dired-create-files' records failing file names. 44Functions that operate recursively can store additional names 45into this list; they also should call `dired-log' to log the errors.") 46 47;;; 15K 48;;;###begin dired-cmd.el 49;; Diffing and compressing 50 51(defconst dired-star-subst-regexp "\\(^\\|[ \t]\\)\\*\\([ \t]\\|$\\)") 52(defconst dired-quark-subst-regexp "\\(^\\|[ \t]\\)\\?\\([ \t]\\|$\\)") 53 54;;;###autoload 55(defun dired-diff (file &optional switches) 56 "Compare file at point with file FILE using `diff'. 57FILE defaults to the file at the mark. (That's the mark set by 58\\[set-mark-command], not by Dired's \\[dired-mark] command.) 59The prompted-for file is the first file given to `diff'. 60With prefix arg, prompt for second argument SWITCHES, 61which is options for `diff'." 62 (interactive 63 (let ((current (dired-get-filename t)) 64 (default (if (mark t) 65 (save-excursion (goto-char (mark t)) 66 (dired-get-filename t t))))) 67 (if (or (equal default current) 68 (and (not (equal (dired-dwim-target-directory) 69 (dired-current-directory))) 70 (not mark-active))) 71 (setq default nil)) 72 (require 'diff) 73 (list (read-file-name (format "Diff %s with%s: " 74 current 75 (if default 76 (concat " (default " default ")") 77 "")) 78 (if default 79 (dired-current-directory) 80 (dired-dwim-target-directory)) 81 default t) 82 (if current-prefix-arg 83 (read-string "Options for diff: " 84 (if (stringp diff-switches) 85 diff-switches 86 (mapconcat 'identity diff-switches " "))))))) 87 (diff file (dired-get-filename t) switches)) 88 89;;;###autoload 90(defun dired-backup-diff (&optional switches) 91 "Diff this file with its backup file or vice versa. 92Uses the latest backup, if there are several numerical backups. 93If this file is a backup, diff it with its original. 94The backup file is the first file given to `diff'. 95With prefix arg, prompt for argument SWITCHES which is options for `diff'." 96 (interactive 97 (if current-prefix-arg 98 (list (read-string "Options for diff: " 99 (if (stringp diff-switches) 100 diff-switches 101 (mapconcat 'identity diff-switches " ")))) 102 nil)) 103 (diff-backup (dired-get-filename) switches)) 104 105;;;###autoload 106(defun dired-compare-directories (dir2 predicate) 107 "Mark files with different file attributes in two dired buffers. 108Compare file attributes of files in the current directory 109with file attributes in directory DIR2 using PREDICATE on pairs of files 110with the same name. Mark files for which PREDICATE returns non-nil. 111Mark files with different names if PREDICATE is nil (or interactively 112with empty input at the predicate prompt). 113 114PREDICATE is a Lisp expression that can refer to the following variables: 115 116 size1, size2 - file size in bytes 117 mtime1, mtime2 - last modification time in seconds, as a float 118 fa1, fa2 - list of file attributes 119 returned by function `file-attributes' 120 121 where 1 refers to attribute of file in the current dired buffer 122 and 2 to attribute of file in second dired buffer. 123 124Examples of PREDICATE: 125 126 (> mtime1 mtime2) - mark newer files 127 (not (= size1 size2)) - mark files with different sizes 128 (not (string= (nth 8 fa1) (nth 8 fa2))) - mark files with different modes 129 (not (and (= (nth 2 fa1) (nth 2 fa2)) - mark files with different UID 130 (= (nth 3 fa1) (nth 3 fa2)))) and GID." 131 (interactive 132 (list (read-directory-name (format "Compare %s with: " 133 (dired-current-directory)) 134 (dired-dwim-target-directory) 135 (dired-dwim-target-directory)) 136 (read-from-minibuffer "Mark if (lisp expr or RET): " nil nil t nil "nil"))) 137 (let* ((dir1 (dired-current-directory)) 138 (file-alist1 (dired-files-attributes dir1)) 139 (file-alist2 (dired-files-attributes dir2)) 140 file-list1 file-list2) 141 (setq file-alist1 (delq (assoc "." file-alist1) file-alist1)) 142 (setq file-alist1 (delq (assoc ".." file-alist1) file-alist1)) 143 (setq file-alist2 (delq (assoc "." file-alist2) file-alist2)) 144 (setq file-alist2 (delq (assoc ".." file-alist2) file-alist2)) 145 (setq file-list1 (mapcar 146 'cadr 147 (dired-file-set-difference 148 file-alist1 file-alist2 149 predicate)) 150 file-list2 (mapcar 151 'cadr 152 (dired-file-set-difference 153 file-alist2 file-alist1 154 predicate))) 155 (dired-fun-in-all-buffers 156 dir1 nil 157 (lambda () 158 (dired-mark-if 159 (member (dired-get-filename nil t) file-list1) nil))) 160 (dired-fun-in-all-buffers 161 dir2 nil 162 (lambda () 163 (dired-mark-if 164 (member (dired-get-filename nil t) file-list2) nil))) 165 (message "Marked in dir1: %s files, in dir2: %s files" 166 (length file-list1) 167 (length file-list2)))) 168 169(defun dired-file-set-difference (list1 list2 predicate) 170 "Combine LIST1 and LIST2 using a set-difference operation. 171The result list contains all file items that appear in LIST1 but not LIST2. 172This is a non-destructive function; it makes a copy of the data if necessary 173to avoid corrupting the original LIST1 and LIST2. 174PREDICATE (see `dired-compare-directories') is an additional match 175condition. Two file items are considered to match if they are equal 176*and* PREDICATE evaluates to t." 177 (if (or (null list1) (null list2)) 178 list1 179 (let (res) 180 (dolist (file1 list1) 181 (unless (let ((list list2)) 182 (while (and list 183 (not (let* ((file2 (car list)) 184 (fa1 (car (cddr file1))) 185 (fa2 (car (cddr file2))) 186 (size1 (nth 7 fa1)) 187 (size2 (nth 7 fa2)) 188 (mtime1 (float-time (nth 5 fa1))) 189 (mtime2 (float-time (nth 5 fa2)))) 190 (and 191 (equal (car file1) (car file2)) 192 (not (eval predicate)))))) 193 (setq list (cdr list))) 194 list) 195 (setq res (cons file1 res)))) 196 (nreverse res)))) 197 198(defun dired-files-attributes (dir) 199 "Return a list of all file names and attributes from DIR. 200List has a form of (file-name full-file-name (attribute-list))" 201 (mapcar 202 (lambda (file-name) 203 (let ((full-file-name (expand-file-name file-name dir))) 204 (list file-name 205 full-file-name 206 (file-attributes full-file-name)))) 207 (directory-files dir))) 208 209 210(defun dired-touch-initial (files) 211 "Create initial input value for `touch' command." 212 (let (initial) 213 (while files 214 (let ((current (nth 5 (file-attributes (car files))))) 215 (if (and initial (not (equal initial current))) 216 (setq initial (current-time) files nil) 217 (setq initial current)) 218 (setq files (cdr files)))) 219 (format-time-string "%Y%m%d%H%M.%S" initial))) 220 221(defun dired-do-chxxx (attribute-name program op-symbol arg) 222 ;; Change file attributes (mode, group, owner, timestamp) of marked files and 223 ;; refresh their file lines. 224 ;; ATTRIBUTE-NAME is a string describing the attribute to the user. 225 ;; PROGRAM is the program used to change the attribute. 226 ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). 227 ;; ARG describes which files to use, as in dired-get-marked-files. 228 (let* ((files (dired-get-marked-files t arg)) 229 (new-attribute 230 (dired-mark-read-string 231 (concat "Change " attribute-name " of %s to: ") 232 (if (eq op-symbol 'touch) (dired-touch-initial files)) 233 op-symbol arg files)) 234 (operation (concat program " " new-attribute)) 235 failures) 236 (setq failures 237 (dired-bunch-files 10000 238 (function dired-check-process) 239 (append 240 (list operation program) 241 (if (eq op-symbol 'touch) 242 '("-t") nil) 243 (list new-attribute) 244 (if (string-match "gnu" system-configuration) 245 '("--") nil)) 246 files)) 247 (dired-do-redisplay arg);; moves point if ARG is an integer 248 (if failures 249 (dired-log-summary 250 (format "%s: error" operation) 251 nil)))) 252 253;;;###autoload 254(defun dired-do-chmod (&optional arg) 255 "Change the mode of the marked (or next ARG) files. 256This calls chmod, thus symbolic modes like `g+w' are allowed." 257 (interactive "P") 258 (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg)) 259 260;;;###autoload 261(defun dired-do-chgrp (&optional arg) 262 "Change the group of the marked (or next ARG) files." 263 (interactive "P") 264 (if (memq system-type '(ms-dos windows-nt)) 265 (error "chgrp not supported on this system")) 266 (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) 267 268;;;###autoload 269(defun dired-do-chown (&optional arg) 270 "Change the owner of the marked (or next ARG) files." 271 (interactive "P") 272 (if (memq system-type '(ms-dos windows-nt)) 273 (error "chown not supported on this system")) 274 (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) 275 276;;;###autoload 277(defun dired-do-touch (&optional arg) 278 "Change the timestamp of the marked (or next ARG) files. 279This calls touch." 280 (interactive "P") 281 (dired-do-chxxx "Timestamp" dired-touch-program 'touch arg)) 282 283;; Process all the files in FILES in batches of a convenient size, 284;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). 285;; Batches are chosen to need less than MAX chars for the file names, 286;; allowing 3 extra characters of separator per file name. 287(defun dired-bunch-files (max function args files) 288 (let (pending 289 past 290 (pending-length 0) 291 failures) 292 ;; Accumulate files as long as they fit in MAX chars, 293 ;; then process the ones accumulated so far. 294 (while files 295 (let* ((thisfile (car files)) 296 (thislength (+ (length thisfile) 3)) 297 (rest (cdr files))) 298 ;; If we have at least 1 pending file 299 ;; and this file won't fit in the length limit, process now. 300 (if (and pending (> (+ thislength pending-length) max)) 301 (setq pending (nreverse pending) 302 ;; The elements of PENDING are now in forward order. 303 ;; Do the operation and record failures. 304 failures (nconc (apply function (append args pending)) 305 failures) 306 ;; Transfer the elemens of PENDING onto PAST 307 ;; and clear it out. Now PAST contains the first N files 308 ;; specified (for some N), and FILES contains the rest. 309 past (nconc past pending) 310 pending nil 311 pending-length 0)) 312 ;; Do (setq pending (cons thisfile pending)) 313 ;; but reuse the cons that was in `files'. 314 (setcdr files pending) 315 (setq pending files) 316 (setq pending-length (+ thislength pending-length)) 317 (setq files rest))) 318 (setq pending (nreverse pending)) 319 (prog1 320 (nconc (apply function (append args pending)) 321 failures) 322 ;; Now the original list FILES has been put back as it was. 323 (nconc past pending)))) 324 325;;;###autoload 326(defun dired-do-print (&optional arg) 327 "Print the marked (or next ARG) files. 328Uses the shell command coming from variables `lpr-command' and 329`lpr-switches' as default." 330 (interactive "P") 331 (let* ((file-list (dired-get-marked-files t arg)) 332 (command (dired-mark-read-string 333 "Print %s with: " 334 (mapconcat 'identity 335 (cons lpr-command 336 (if (stringp lpr-switches) 337 (list lpr-switches) 338 lpr-switches)) 339 " ") 340 'print arg file-list))) 341 (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))) 342 343;; Read arguments for a marked-files command that wants a string 344;; that is not a file name, 345;; perhaps popping up the list of marked files. 346;; ARG is the prefix arg and indicates whether the files came from 347;; marks (ARG=nil) or a repeat factor (integerp ARG). 348;; If the current file was used, the list has but one element and ARG 349;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). 350 351(defun dired-mark-read-string (prompt initial op-symbol arg files) 352 ;; PROMPT for a string, with INITIAL input. 353 ;; Other args are used to give user feedback and pop-up: 354 ;; OP-SYMBOL of command, prefix ARG, marked FILES. 355 (dired-mark-pop-up 356 nil op-symbol files 357 (function read-string) 358 (format prompt (dired-mark-prompt arg files)) initial)) 359 360;;; Cleaning a directory: flagging some backups for deletion. 361 362(defvar dired-file-version-alist) 363 364;;;###autoload 365(defun dired-clean-directory (keep) 366 "Flag numerical backups for deletion. 367Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. 368Positive prefix arg KEEP overrides `dired-kept-versions'; 369Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. 370 371To clear the flags on these files, you can use \\[dired-flag-backup-files] 372with a prefix argument." 373 (interactive "P") 374 (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) 375 (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) 376 (late-retention (if (<= keep 0) dired-kept-versions keep)) 377 (dired-file-version-alist ())) 378 (message "Cleaning numerical backups (keeping %d late, %d old)..." 379 late-retention early-retention) 380 ;; Look at each file. 381 ;; If the file has numeric backup versions, 382 ;; put on dired-file-version-alist an element of the form 383 ;; (FILENAME . VERSION-NUMBER-LIST) 384 (dired-map-dired-file-lines (function dired-collect-file-versions)) 385 ;; Sort each VERSION-NUMBER-LIST, 386 ;; and remove the versions not to be deleted. 387 (let ((fval dired-file-version-alist)) 388 (while fval 389 (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) 390 (v-count (length sorted-v-list))) 391 (if (> v-count (+ early-retention late-retention)) 392 (rplacd (nthcdr early-retention sorted-v-list) 393 (nthcdr (- v-count late-retention) 394 sorted-v-list))) 395 (rplacd (car fval) 396 (cdr sorted-v-list))) 397 (setq fval (cdr fval)))) 398 ;; Look at each file. If it is a numeric backup file, 399 ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. 400 (dired-map-dired-file-lines (function dired-trample-file-versions)) 401 (message "Cleaning numerical backups...done"))) 402 403;;; Subroutines of dired-clean-directory. 404 405(defun dired-map-dired-file-lines (fun) 406 ;; Perform FUN with point at the end of each non-directory line. 407 ;; FUN takes one argument, the absolute filename. 408 (save-excursion 409 (let (file buffer-read-only) 410 (goto-char (point-min)) 411 (while (not (eobp)) 412 (save-excursion 413 (and (not (looking-at dired-re-dir)) 414 (not (eolp)) 415 (setq file (dired-get-filename nil t)) ; nil on non-file 416 (progn (end-of-line) 417 (funcall fun file)))) 418 (forward-line 1))))) 419 420(defun dired-collect-file-versions (fn) 421 (let ((fn (file-name-sans-versions fn))) 422 ;; Only do work if this file is not already in the alist. 423 (if (assoc fn dired-file-version-alist) 424 nil 425 ;; If it looks like file FN has versions, return a list of the versions. 426 ;;That is a list of strings which are file names. 427 ;;The caller may want to flag some of these files for deletion. 428 (let* ((base-versions 429 (concat (file-name-nondirectory fn) ".~")) 430 (backup-extract-version-start (length base-versions)) 431 (possibilities (file-name-all-completions 432 base-versions 433 (file-name-directory fn))) 434 (versions (mapcar 'backup-extract-version possibilities))) 435 (if versions 436 (setq dired-file-version-alist 437 (cons (cons fn versions) 438 dired-file-version-alist))))))) 439 440(defun dired-trample-file-versions (fn) 441 (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) 442 base-version-list) 443 (and start-vn 444 (setq base-version-list ; there was a base version to which 445 (assoc (substring fn 0 start-vn) ; this looks like a 446 dired-file-version-alist)) ; subversion 447 (not (memq (string-to-number (substring fn (+ 2 start-vn))) 448 base-version-list)) ; this one doesn't make the cut 449 (progn (beginning-of-line) 450 (delete-char 1) 451 (insert dired-del-marker))))) 452 453;;; Shell commands 454 455(defun dired-read-shell-command (prompt arg files) 456;; "Read a dired shell command prompting with PROMPT (using read-string). 457;;ARG is the prefix arg and may be used to indicate in the prompt which 458;; files are affected. 459;;This is an extra function so that you can redefine it, e.g., to use gmhist." 460 (dired-mark-pop-up 461 nil 'shell files 462 (function read-string) 463 (format prompt (dired-mark-prompt arg files)) 464 nil 'shell-command-history)) 465 466;; The in-background argument is only needed in Emacs 18 where 467;; shell-command doesn't understand an appended ampersand `&'. 468;;;###autoload 469(defun dired-do-shell-command (command &optional arg file-list) 470 "Run a shell command COMMAND on the marked files. 471If no files are marked or a specific numeric prefix arg is given, 472the next ARG files are used. Just \\[universal-argument] means the current file. 473The prompt mentions the file(s) or the marker, as appropriate. 474 475If there is a `*' in COMMAND, surrounded by whitespace, this runs 476COMMAND just once with the entire file list substituted there. 477 478If there is no `*', but there is a `?' in COMMAND, surrounded by 479whitespace, this runs COMMAND on each file individually with the 480file name substituted for `?'. 481 482Otherwise, this runs COMMAND on each file individually with the 483file name added at the end of COMMAND (separated by a space). 484 485`*' and `?' when not surrounded by whitespace have no special 486significance for `dired-do-shell-command', and are passed through 487normally to the shell, but you must confirm first. To pass `*' by 488itself to the shell as a wildcard, type `*\"\"'. 489 490If COMMAND produces output, it goes to a separate buffer. 491 492This feature does not try to redisplay Dired buffers afterward, as 493there's no telling what files COMMAND may have changed. 494Type \\[dired-do-redisplay] to redisplay the marked files. 495 496When COMMAND runs, its working directory is the top-level directory of 497the Dired buffer, so output files usually are created there instead of 498in a subdir. 499 500In a noninteractive call (from Lisp code), you must specify 501the list of file names explicitly with the FILE-LIST argument, which 502can be produced by `dired-get-marked-files', for example." 503;;Functions dired-run-shell-command and dired-shell-stuff-it do the 504;;actual work and can be redefined for customization. 505 (interactive 506 (let ((files (dired-get-marked-files t current-prefix-arg))) 507 (list 508 ;; Want to give feedback whether this file or marked files are used: 509 (dired-read-shell-command (concat "! on " 510 "%s: ") 511 current-prefix-arg 512 files) 513 current-prefix-arg 514 files))) 515 (let* ((on-each (not (string-match dired-star-subst-regexp command))) 516 (subst (not (string-match dired-quark-subst-regexp command))) 517 (star (not (string-match "\\*" command))) 518 (qmark (not (string-match "\\?" command)))) 519 ;; Get confirmation for wildcards that may have been meant 520 ;; to control substitution of a file name or the file name list. 521 (if (cond ((not (or on-each subst)) 522 (error "You can not combine `*' and `?' substitution marks")) 523 ((and star (not on-each)) 524 (y-or-n-p "Confirm--do you mean to use `*' as a wildcard? ")) 525 ((and qmark (not subst)) 526 (y-or-n-p "Confirm--do you mean to use `?' as a wildcard? ")) 527 (t)) 528 (if on-each 529 (dired-bunch-files 530 (- 10000 (length command)) 531 (function (lambda (&rest files) 532 (dired-run-shell-command 533 (dired-shell-stuff-it command files t arg)))) 534 nil 535 file-list) 536 ;; execute the shell command 537 (dired-run-shell-command 538 (dired-shell-stuff-it command file-list nil arg)))))) 539 540;; Might use {,} for bash or csh: 541(defvar dired-mark-prefix "" 542 "Prepended to marked files in dired shell commands.") 543(defvar dired-mark-postfix "" 544 "Appended to marked files in dired shell commands.") 545(defvar dired-mark-separator " " 546 "Separates marked files in dired shell commands.") 547 548(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) 549;; "Make up a shell command line from COMMAND and FILE-LIST. 550;; If ON-EACH is t, COMMAND should be applied to each file, else 551;; simply concat all files and apply COMMAND to this. 552;; FILE-LIST's elements will be quoted for the shell." 553;; Might be redefined for smarter things and could then use RAW-ARG 554;; (coming from interactive P and currently ignored) to decide what to do. 555;; Smart would be a way to access basename or extension of file names. 556 (let ((stuff-it 557 (if (or (string-match dired-star-subst-regexp command) 558 (string-match dired-quark-subst-regexp command)) 559 (lambda (x) 560 (let ((retval command)) 561 (while (string-match 562 "\\(^\\|[ \t]\\)\\([*?]\\)\\([ \t]\\|$\\)" retval) 563 (setq retval (replace-match x t t retval 2))) 564 retval)) 565 (lambda (x) (concat command dired-mark-separator x))))) 566 (if on-each 567 (mapconcat stuff-it (mapcar 'shell-quote-argument file-list) ";") 568 (let ((files (mapconcat 'shell-quote-argument 569 file-list dired-mark-separator))) 570 (if (> (length file-list) 1) 571 (setq files (concat dired-mark-prefix files dired-mark-postfix))) 572 (funcall stuff-it files))))) 573 574;; This is an extra function so that it can be redefined by ange-ftp. 575;;;###autoload 576(defun dired-run-shell-command (command) 577 (let ((handler 578 (find-file-name-handler (directory-file-name default-directory) 579 'shell-command))) 580 (if handler (apply handler 'shell-command (list command)) 581 (shell-command command))) 582 ;; Return nil for sake of nconc in dired-bunch-files. 583 nil) 584 585;; In Emacs 19 this will return program's exit status. 586;; This is a separate function so that ange-ftp can redefine it. 587(defun dired-call-process (program discard &rest arguments) 588; "Run PROGRAM with output to current buffer unless DISCARD is t. 589;Remaining arguments are strings passed as command arguments to PROGRAM." 590 ;; Look for a handler for default-directory in case it is a remote file name. 591 (let ((handler 592 (find-file-name-handler (directory-file-name default-directory) 593 'dired-call-process))) 594 (if handler (apply handler 'dired-call-process 595 program discard arguments) 596 (apply 'call-process program nil (not discard) nil arguments)))) 597 598(defun dired-check-process (msg program &rest arguments) 599; "Display MSG while running PROGRAM, and check for output. 600;Remaining arguments are strings passed as command arguments to PROGRAM. 601; On error, insert output 602; in a log buffer and return the offending ARGUMENTS or PROGRAM. 603; Caller can cons up a list of failed args. 604;Else returns nil for success." 605 (let (err-buffer err (dir default-directory)) 606 (message "%s..." msg) 607 (save-excursion 608 ;; Get a clean buffer for error output: 609 (setq err-buffer (get-buffer-create " *dired-check-process output*")) 610 (set-buffer err-buffer) 611 (erase-buffer) 612 (setq default-directory dir ; caller's default-directory 613 err (not (eq 0 614 (apply (function dired-call-process) program nil arguments)))) 615 (if err 616 (progn 617 (dired-log (concat program " " (prin1-to-string arguments) "\n")) 618 (dired-log err-buffer) 619 (or arguments program t)) 620 (kill-buffer err-buffer) 621 (message "%s...done" msg) 622 nil)))) 623 624;; Commands that delete or redisplay part of the dired buffer. 625 626(defun dired-kill-line (&optional arg) 627 (interactive "P") 628 (setq arg (prefix-numeric-value arg)) 629 (let (buffer-read-only file) 630 (while (/= 0 arg) 631 (setq file (dired-get-filename nil t)) 632 (if (not file) 633 (error "Can only kill file lines") 634 (save-excursion (and file 635 (dired-goto-subdir file) 636 (dired-kill-subdir))) 637 (delete-region (progn (beginning-of-line) (point)) 638 (progn (forward-line 1) (point))) 639 (if (> arg 0) 640 (setq arg (1- arg)) 641 (setq arg (1+ arg)) 642 (forward-line -1)))) 643 (dired-move-to-filename))) 644 645;;;###autoload 646(defun dired-do-kill-lines (&optional arg fmt) 647 "Kill all marked lines (not the files). 648With a prefix argument, kill that many lines starting with the current line. 649\(A negative argument kills backward.) 650If you use this command with a prefix argument to kill the line 651for a file that is a directory, which you have inserted in the 652Dired buffer as a subdirectory, then it deletes that subdirectory 653from the buffer as well. 654To kill an entire subdirectory \(without killing its line in the 655parent directory), go to its directory header line and use this 656command with a prefix argument (the value does not matter)." 657 ;; Returns count of killed lines. FMT="" suppresses message. 658 (interactive "P") 659 (if arg 660 (if (dired-get-subdir) 661 (dired-kill-subdir) 662 (dired-kill-line arg)) 663 (save-excursion 664 (goto-char (point-min)) 665 (let (buffer-read-only 666 (count 0) 667 (regexp (dired-marker-regexp))) 668 (while (and (not (eobp)) 669 (re-search-forward regexp nil t)) 670 (setq count (1+ count)) 671 (delete-region (progn (beginning-of-line) (point)) 672 (progn (forward-line 1) (point)))) 673 (or (equal "" fmt) 674 (message (or fmt "Killed %d line%s.") count (dired-plural-s count))) 675 count)))) 676 677;;;###end dired-cmd.el 678 679;;; 30K 680;;;###begin dired-cp.el 681 682(defun dired-compress () 683 ;; Compress or uncompress the current file. 684 ;; Return nil for success, offending filename else. 685 (let* (buffer-read-only 686 (from-file (dired-get-filename)) 687 (new-file (dired-compress-file from-file))) 688 (if new-file 689 (let ((start (point))) 690 ;; Remove any preexisting entry for the name NEW-FILE. 691 (condition-case nil 692 (dired-remove-entry new-file) 693 (error nil)) 694 (goto-char start) 695 ;; Now replace the current line with an entry for NEW-FILE. 696 (dired-update-file-line new-file) nil) 697 (dired-log (concat "Failed to compress" from-file)) 698 from-file))) 699 700(defvar dired-compress-file-suffixes 701 '(("\\.gz\\'" "" "gunzip") 702 ("\\.tgz\\'" ".tar" "gunzip") 703 ("\\.Z\\'" "" "uncompress") 704 ;; For .z, try gunzip. It might be an old gzip file, 705 ;; or it might be from compact? pack? (which?) but gunzip handles both. 706 ("\\.z\\'" "" "gunzip") 707 ("\\.dz\\'" "" "dictunzip") 708 ("\\.tbz\\'" ".tar" "bunzip2") 709 ("\\.bz2\\'" "" "bunzip2") 710 ;; This item controls naming for compression. 711 ("\\.tar\\'" ".tgz" nil)) 712 "Control changes in file name suffixes for compression and uncompression. 713Each element specifies one transformation rule, and has the form: 714 (REGEXP NEW-SUFFIX PROGRAM) 715The rule applies when the old file name matches REGEXP. 716The new file name is computed by deleting the part that matches REGEXP 717 (as well as anything after that), then adding NEW-SUFFIX in its place. 718If PROGRAM is non-nil, the rule is an uncompression rule, 719and uncompression is done by running PROGRAM. 720Otherwise, the rule is a compression rule, and compression is done with gzip.") 721 722;;;###autoload 723(defun dired-compress-file (file) 724 ;; Compress or uncompress FILE. 725 ;; Return the name of the compressed or uncompressed file. 726 ;; Return nil if no change in files. 727 (let ((handler (find-file-name-handler file 'dired-compress-file)) 728 suffix newname 729 (suffixes dired-compress-file-suffixes)) 730 ;; See if any suffix rule matches this file name. 731 (while suffixes 732 (let (case-fold-search) 733 (if (string-match (car (car suffixes)) file) 734 (setq suffix (car suffixes) suffixes nil)) 735 (setq suffixes (cdr suffixes)))) 736 ;; If so, compute desired new name. 737 (if suffix 738 (setq newname (concat (substring file 0 (match-beginning 0)) 739 (nth 1 suffix)))) 740 (cond (handler 741 (funcall handler 'dired-compress-file file)) 742 ((file-symlink-p file) 743 nil) 744 ((and suffix (nth 2 suffix)) 745 ;; We found an uncompression rule. 746 (if (not (dired-check-process (concat "Uncompressing " file) 747 (nth 2 suffix) file)) 748 newname)) 749 (t 750 ;;; We don't recognize the file as compressed, so compress it. 751 ;;; Try gzip; if we don't have that, use compress. 752 (condition-case nil 753 (let ((out-name (concat file ".gz"))) 754 (and (or (not (file-exists-p out-name)) 755 (y-or-n-p 756 (format "File %s already exists. Really compress? " 757 out-name))) 758 (not (dired-check-process (concat "Compressing " file) 759 "gzip" "-f" file)) 760 (or (file-exists-p out-name) 761 (setq out-name (concat file ".z"))) 762 ;; Rename the compressed file to NEWNAME 763 ;; if it hasn't got that name already. 764 (if (and newname (not (equal newname out-name))) 765 (progn 766 (rename-file out-name newname t) 767 newname) 768 out-name))) 769 (file-error 770 (if (not (dired-check-process (concat "Compressing " file) 771 "compress" "-f" file)) 772 ;; Don't use NEWNAME with `compress'. 773 (concat file ".Z")))))))) 774 775(defun dired-mark-confirm (op-symbol arg) 776 ;; Request confirmation from the user that the operation described 777 ;; by OP-SYMBOL is to be performed on the marked files. 778 ;; Confirmation consists in a y-or-n question with a file list 779 ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. 780 ;; The files used are determined by ARG (as in dired-get-marked-files). 781 (or (eq dired-no-confirm t) 782 (memq op-symbol dired-no-confirm) 783 ;; Pass t for DISTINGUISH-ONE-MARKED so that a single file which 784 ;; is marked pops up a window. That will help the user see 785 ;; it isn't the current line file. 786 (let ((files (dired-get-marked-files t arg nil t)) 787 (string (if (eq op-symbol 'compress) "Compress or uncompress" 788 (capitalize (symbol-name op-symbol))))) 789 (dired-mark-pop-up nil op-symbol files (function y-or-n-p) 790 (concat string " " 791 (dired-mark-prompt arg files) "? "))))) 792 793(defun dired-map-over-marks-check (fun arg op-symbol &optional show-progress) 794; "Map FUN over marked files (with second ARG like in dired-map-over-marks) 795; and display failures. 796 797; FUN takes zero args. It returns non-nil (the offending object, e.g. 798; the short form of the filename) for a failure and probably logs a 799; detailed error explanation using function `dired-log'. 800 801; OP-SYMBOL is a symbol describing the operation performed (e.g. 802; `compress'). It is used with `dired-mark-pop-up' to prompt the user 803; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. 804; `Failed to compress 1 of 2 files - type W to see why ("foo")') 805 806; SHOW-PROGRESS if non-nil means redisplay dired after each file." 807 (if (dired-mark-confirm op-symbol arg) 808 (let* ((total-list;; all of FUN's return values 809 (dired-map-over-marks (funcall fun) arg show-progress)) 810 (total (length total-list)) 811 (failures (delq nil total-list)) 812 (count (length failures)) 813 (string (if (eq op-symbol 'compress) "Compress or uncompress" 814 (capitalize (symbol-name op-symbol))))) 815 (if (not failures) 816 (message "%s: %d file%s." 817 string total (dired-plural-s total)) 818 ;; end this bunch of errors: 819 (dired-log-summary 820 (format "Failed to %s %d of %d file%s" 821 (downcase string) count total (dired-plural-s total)) 822 failures))))) 823 824(defvar dired-query-alist 825 '((?\y . y) (?\040 . y) ; `y' or SPC means accept once 826 (?n . n) (?\177 . n) ; `n' or DEL skips once 827 (?! . yes) ; `!' accepts rest 828 (?q . no) (?\e . no) ; `q' or ESC skips rest 829 ;; None of these keys quit - use C-g for that. 830 )) 831 832;;;###autoload 833(defun dired-query (qs-var qs-prompt &rest qs-args) 834 ;; Query user and return nil or t. 835 ;; Store answer in symbol VAR (which must initially be bound to nil). 836 ;; Format PROMPT with ARGS. 837 ;; Binding variable help-form will help the user who types the help key. 838 (let* ((char (symbol-value qs-var)) 839 (action (cdr (assoc char dired-query-alist)))) 840 (cond ((eq 'yes action) 841 t) ; accept, and don't ask again 842 ((eq 'no action) 843 nil) ; skip, and don't ask again 844 (t;; no lasting effects from last time we asked - ask now 845 (let ((qprompt (concat qs-prompt 846 (if help-form 847 (format " [Type yn!q or %s] " 848 (key-description 849 (char-to-string help-char))) 850 " [Type y, n, q or !] "))) 851 result elt) 852 ;; Actually it looks nicer without cursor-in-echo-area - you can 853 ;; look at the dired buffer instead of at the prompt to decide. 854 (apply 'message qprompt qs-args) 855 (setq char (set qs-var (read-char))) 856 (while (not (setq elt (assoc char dired-query-alist))) 857 (message "Invalid char - type %c for help." help-char) 858 (ding) 859 (sit-for 1) 860 (apply 'message qprompt qs-args) 861 (setq char (set qs-var (read-char)))) 862 ;; Display the question with the answer. 863 (message "%s" (concat (apply 'format qprompt qs-args) 864 (char-to-string char))) 865 (memq (cdr elt) '(t y yes))))))) 866 867;;;###autoload 868(defun dired-do-compress (&optional arg) 869 "Compress or uncompress marked (or next ARG) files." 870 (interactive "P") 871 (dired-map-over-marks-check (function dired-compress) arg 'compress t)) 872 873;; Commands for Emacs Lisp files - load and byte compile 874 875(defun dired-byte-compile () 876 ;; Return nil for success, offending file name else. 877 (let* ((filename (dired-get-filename)) 878 elc-file buffer-read-only failure) 879 (condition-case err 880 (save-excursion (byte-compile-file filename)) 881 (error 882 (setq failure err))) 883 (setq elc-file (byte-compile-dest-file filename)) 884 (or (file-exists-p elc-file) 885 (setq failure t)) 886 (if failure 887 (progn 888 (dired-log "Byte compile error for %s:\n%s\n" filename failure) 889 (dired-make-relative filename)) 890 (dired-remove-file elc-file) 891 (forward-line) ; insert .elc after its .el file 892 (dired-add-file elc-file) 893 nil))) 894 895;;;###autoload 896(defun dired-do-byte-compile (&optional arg) 897 "Byte compile marked (or next ARG) Emacs Lisp files." 898 (interactive "P") 899 (dired-map-over-marks-check (function dired-byte-compile) arg 'byte-compile t)) 900 901(defun dired-load () 902 ;; Return nil for success, offending file name else. 903 (let ((file (dired-get-filename)) failure) 904 (condition-case err 905 (load file nil nil t) 906 (error (setq failure err))) 907 (if (not failure) 908 nil 909 (dired-log "Load error for %s:\n%s\n" file failure) 910 (dired-make-relative file)))) 911 912;;;###autoload 913(defun dired-do-load (&optional arg) 914 "Load the marked (or next ARG) Emacs Lisp files." 915 (interactive "P") 916 (dired-map-over-marks-check (function dired-load) arg 'load t)) 917 918;;;###autoload 919(defun dired-do-redisplay (&optional arg test-for-subdir) 920 "Redisplay all marked (or next ARG) files. 921If on a subdir line, redisplay that subdirectory. In that case, 922a prefix arg lets you edit the `ls' switches used for the new listing. 923 924Dired remembers switches specified with a prefix arg, so that reverting 925the buffer will not reset them. However, using `dired-undo' to re-insert 926or delete subdirectories can bypass this machinery. Hence, you sometimes 927may have to reset some subdirectory switches after a `dired-undo'. 928You can reset all subdirectory switches to the default using 929\\<dired-mode-map>\\[dired-reset-subdir-switches]. 930See Info node `(emacs)Subdir switches' for more details." 931 ;; Moves point if the next ARG files are redisplayed. 932 (interactive "P\np") 933 (if (and test-for-subdir (dired-get-subdir)) 934 (let* ((dir (dired-get-subdir)) 935 (switches (cdr (assoc-string dir dired-switches-alist)))) 936 (dired-insert-subdir 937 dir 938 (when arg 939 (read-string "Switches for listing: " 940 (or switches 941 dired-subdir-switches 942 dired-actual-switches))))) 943 (message "Redisplaying...") 944 ;; message much faster than making dired-map-over-marks show progress 945 (dired-uncache 946 (if (consp dired-directory) (car dired-directory) dired-directory)) 947 (dired-map-over-marks (let ((fname (dired-get-filename))) 948 (message "Redisplaying... %s" fname) 949 (dired-update-file-line fname)) 950 arg) 951 (dired-move-to-filename) 952 (message "Redisplaying...done"))) 953 954(defun dired-reset-subdir-switches () 955 "Set `dired-switches-alist' to nil and revert dired buffer." 956 (interactive) 957 (setq dired-switches-alist nil) 958 (revert-buffer)) 959 960(defun dired-update-file-line (file) 961 ;; Delete the current line, and insert an entry for FILE. 962 ;; If FILE is nil, then just delete the current line. 963 ;; Keeps any marks that may be present in column one (doing this 964 ;; here is faster than with dired-add-entry's optional arg). 965 ;; Does not update other dired buffers. Use dired-relist-entry for that. 966 (beginning-of-line) 967 (let ((char (following-char)) (opoint (point)) 968 (buffer-read-only)) 969 (delete-region (point) (progn (forward-line 1) (point))) 970 (if file 971 (progn 972 (dired-add-entry file nil t) 973 ;; Replace space by old marker without moving point. 974 ;; Faster than goto+insdel inside a save-excursion? 975 (subst-char-in-region opoint (1+ opoint) ?\040 char)))) 976 (dired-move-to-filename)) 977 978;;;###autoload 979(defun dired-add-file (filename &optional marker-char) 980 (dired-fun-in-all-buffers 981 (file-name-directory filename) (file-name-nondirectory filename) 982 (function dired-add-entry) filename marker-char)) 983 984(defun dired-add-entry (filename &optional marker-char relative) 985 ;; Add a new entry for FILENAME, optionally marking it 986 ;; with MARKER-CHAR (a character, else dired-marker-char is used). 987 ;; Note that this adds the entry `out of order' if files sorted by 988 ;; time, etc. 989 ;; At least this version inserts in the right subdirectory (if present). 990 ;; And it skips "." or ".." (see `dired-trivial-filenames'). 991 ;; Hidden subdirs are exposed if a file is added there. 992 (setq filename (directory-file-name filename)) 993 ;; Entry is always for files, even if they happen to also be directories 994 (let* ((opoint (point)) 995 (cur-dir (dired-current-directory)) 996 (orig-file-name filename) 997 (directory (if relative cur-dir (file-name-directory filename))) 998 reason) 999 (setq filename 1000 (if relative 1001 (file-relative-name filename directory) 1002 (file-name-nondirectory filename)) 1003 reason 1004 (catch 'not-found 1005 (if (string= directory cur-dir) 1006 (progn 1007 (skip-chars-forward "^\r\n") 1008 (if (eq (following-char) ?\r) 1009 (dired-unhide-subdir)) 1010 ;; We are already where we should be, except when 1011 ;; point is before the subdir line or its total line. 1012 (let ((p (dired-after-subdir-garbage cur-dir))) 1013 (if (< (point) p) 1014 (goto-char p)))) 1015 ;; else try to find correct place to insert 1016 (if (dired-goto-subdir directory) 1017 (progn ;; unhide if necessary 1018 (if (looking-at "\r") ;; point is at end of subdir line 1019 (dired-unhide-subdir)) 1020 ;; found - skip subdir and `total' line 1021 ;; and uninteresting files like . and .. 1022 ;; This better not moves into the next subdir! 1023 (dired-goto-next-nontrivial-file)) 1024 ;; not found 1025 (throw 'not-found "Subdir not found"))) 1026 (let (buffer-read-only opoint) 1027 (beginning-of-line) 1028 (setq opoint (point)) 1029 ;; Don't expand `.'. Show just the file name within directory. 1030 (let ((default-directory directory)) 1031 (dired-insert-directory directory 1032 (concat dired-actual-switches "d") 1033 (list filename))) 1034 (goto-char opoint) 1035 ;; Put in desired marker char. 1036 (when marker-char 1037 (let ((dired-marker-char 1038 (if (integerp marker-char) marker-char dired-marker-char))) 1039 (dired-mark nil))) 1040 ;; Compensate for a bug in ange-ftp. 1041 ;; It inserts the file's absolute name, rather than 1042 ;; the relative one. That may be hard to fix since it 1043 ;; is probably controlled by something in ftp. 1044 (goto-char opoint) 1045 (let ((inserted-name (dired-get-filename 'verbatim))) 1046 (if (file-name-directory inserted-name) 1047 (let (props) 1048 (end-of-line) 1049 (forward-char (- (length inserted-name))) 1050 (setq props (text-properties-at (point))) 1051 (delete-char (length inserted-name)) 1052 (let ((pt (point))) 1053 (insert filename) 1054 (set-text-properties pt (point) props)) 1055 (forward-char 1)) 1056 (forward-line 1))) 1057 (forward-line -1) 1058 (if dired-after-readin-hook ;; the subdir-alist is not affected... 1059 (save-excursion ;; ...so we can run it right now: 1060 (save-restriction 1061 (beginning-of-line) 1062 (narrow-to-region (point) (save-excursion 1063 (forward-line 1) (point))) 1064 (run-hooks 'dired-after-readin-hook)))) 1065 (dired-move-to-filename)) 1066 ;; return nil if all went well 1067 nil)) 1068 (if reason ; don't move away on failure 1069 (goto-char opoint)) 1070 (not reason))) ; return t on success, nil else 1071 1072(defun dired-after-subdir-garbage (dir) 1073 ;; Return pos of first file line of DIR, skipping header and total 1074 ;; or wildcard lines. 1075 ;; Important: never moves into the next subdir. 1076 ;; DIR is assumed to be unhidden. 1077 ;; Will probably be redefined for VMS etc. 1078 (save-excursion 1079 (or (dired-goto-subdir dir) (error "This cannot happen")) 1080 (forward-line 1) 1081 (while (and (not (eolp)) ; don't cross subdir boundary 1082 (not (dired-move-to-filename))) 1083 (forward-line 1)) 1084 (point))) 1085 1086;;;###autoload 1087(defun dired-remove-file (file) 1088 (dired-fun-in-all-buffers 1089 (file-name-directory file) (file-name-nondirectory file) 1090 (function dired-remove-entry) file)) 1091 1092(defun dired-remove-entry (file) 1093 (save-excursion 1094 (and (dired-goto-file file) 1095 (let (buffer-read-only) 1096 (delete-region (progn (beginning-of-line) (point)) 1097 (save-excursion (forward-line 1) (point))))))) 1098 1099;;;###autoload 1100(defun dired-relist-file (file) 1101 "Create or update the line for FILE in all Dired buffers it would belong in." 1102 (dired-fun-in-all-buffers (file-name-directory file) 1103 (file-name-nondirectory file) 1104 (function dired-relist-entry) file)) 1105 1106(defun dired-relist-entry (file) 1107 ;; Relist the line for FILE, or just add it if it did not exist. 1108 ;; FILE must be an absolute file name. 1109 (let (buffer-read-only marker) 1110 ;; If cursor is already on FILE's line delete-region will cause 1111 ;; save-excursion to fail because of floating makers, 1112 ;; moving point to beginning of line. Sigh. 1113 (save-excursion 1114 (and (dired-goto-file file) 1115 (delete-region (progn (beginning-of-line) 1116 (setq marker (following-char)) 1117 (point)) 1118 (save-excursion (forward-line 1) (point)))) 1119 (setq file (directory-file-name file)) 1120 (dired-add-entry file (if (eq ?\040 marker) nil marker))))) 1121 1122;;; Copy, move/rename, making hard and symbolic links 1123 1124(defcustom dired-backup-overwrite nil 1125 "*Non-nil if Dired should ask about making backups before overwriting files. 1126Special value `always' suppresses confirmation." 1127 :type '(choice (const :tag "off" nil) 1128 (const :tag "suppress" always) 1129 (other :tag "ask" t)) 1130 :group 'dired) 1131 1132(defvar dired-overwrite-confirmed) 1133 1134(defun dired-handle-overwrite (to) 1135 ;; Save old version of file TO that is to be overwritten. 1136 ;; `dired-overwrite-confirmed' and `overwrite-backup-query' are fluid vars 1137 ;; from dired-create-files. 1138 (let (backup) 1139 (if (and dired-backup-overwrite 1140 dired-overwrite-confirmed 1141 (setq backup (car (find-backup-file-name to))) 1142 (or (eq 'always dired-backup-overwrite) 1143 (dired-query 'overwrite-backup-query 1144 "Make backup for existing file `%s'? " 1145 to))) 1146 (progn 1147 (rename-file to backup 0) ; confirm overwrite of old backup 1148 (dired-relist-entry backup))))) 1149 1150;;;###autoload 1151(defun dired-copy-file (from to ok-flag) 1152 (dired-handle-overwrite to) 1153 (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t 1154 dired-recursive-copies)) 1155 1156(defun dired-copy-file-recursive (from to ok-flag &optional 1157 preserve-time top recursive) 1158 (let ((attrs (file-attributes from)) 1159 dirfailed) 1160 (if (and recursive 1161 (eq t (car attrs)) 1162 (or (eq recursive 'always) 1163 (yes-or-no-p (format "Recursive copies of %s? " from)))) 1164 ;; This is a directory. 1165 (let ((files 1166 (condition-case err 1167 (directory-files from nil dired-re-no-dot) 1168 (file-error 1169 (push (dired-make-relative from) 1170 dired-create-files-failures) 1171 (dired-log "Copying error for %s:\n%s\n" from err) 1172 (setq dirfailed t) 1173 nil)))) 1174 (if (eq recursive 'top) (setq recursive 'always)) ; Don't ask any more. 1175 (unless dirfailed 1176 (if (file-exists-p to) 1177 (or top (dired-handle-overwrite to)) 1178 (condition-case err 1179 (make-directory to) 1180 (file-error 1181 (push (dired-make-relative from) 1182 dired-create-files-failures) 1183 (setq files nil) 1184 (dired-log "Copying error for %s:\n%s\n" from err))))) 1185 (dolist (file files) 1186 (let ((thisfrom (expand-file-name file from)) 1187 (thisto (expand-file-name file to))) 1188 ;; Catch errors copying within a directory, 1189 ;; and report them through the dired log mechanism 1190 ;; just as our caller will do for the top level files. 1191 (condition-case err 1192 (dired-copy-file-recursive 1193 thisfrom thisto 1194 ok-flag preserve-time nil recursive) 1195 (file-error 1196 (push (dired-make-relative thisfrom) 1197 dired-create-files-failures) 1198 (dired-log "Copying error for %s:\n%s\n" thisfrom err)))))) 1199 ;; Not a directory. 1200 (or top (dired-handle-overwrite to)) 1201 (condition-case err 1202 (if (stringp (car attrs)) 1203 ;; It is a symlink 1204 (make-symbolic-link (car attrs) to ok-flag) 1205 (copy-file from to ok-flag dired-copy-preserve-time)) 1206 (file-date-error 1207 (push (dired-make-relative from) 1208 dired-create-files-failures) 1209 (dired-log "Can't set date on %s:\n%s\n" from err)))))) 1210 1211;;;###autoload 1212(defun dired-rename-file (file newname ok-if-already-exists) 1213 (dired-handle-overwrite newname) 1214 (rename-file file newname ok-if-already-exists) ; error is caught in -create-files 1215 ;; Silently rename the visited file of any buffer visiting this file. 1216 (and (get-file-buffer file) 1217 (with-current-buffer (get-file-buffer file) 1218 (set-visited-file-name newname nil t))) 1219 (dired-remove-file file) 1220 ;; See if it's an inserted subdir, and rename that, too. 1221 (dired-rename-subdir file newname)) 1222 1223(defun dired-rename-subdir (from-dir to-dir) 1224 (setq from-dir (file-name-as-directory from-dir) 1225 to-dir (file-name-as-directory to-dir)) 1226 (dired-fun-in-all-buffers from-dir nil 1227 (function dired-rename-subdir-1) from-dir to-dir) 1228 ;; Update visited file name of all affected buffers 1229 (let ((expanded-from-dir (expand-file-name from-dir)) 1230 (blist (buffer-list))) 1231 (while blist 1232 (save-excursion 1233 (set-buffer (car blist)) 1234 (if (and buffer-file-name 1235 (dired-in-this-tree buffer-file-name expanded-from-dir)) 1236 (let ((modflag (buffer-modified-p)) 1237 (to-file (dired-replace-in-string 1238 (concat "^" (regexp-quote from-dir)) 1239 to-dir 1240 buffer-file-name))) 1241 (set-visited-file-name to-file) 1242 (set-buffer-modified-p modflag)))) 1243 (setq blist (cdr blist))))) 1244 1245(defun dired-rename-subdir-1 (dir to) 1246 ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or 1247 ;; one of its subdirectories is expanded in this buffer. 1248 (let ((expanded-dir (expand-file-name dir)) 1249 (alist dired-subdir-alist) 1250 (elt nil)) 1251 (while alist 1252 (setq elt (car alist) 1253 alist (cdr alist)) 1254 (if (dired-in-this-tree (car elt) expanded-dir) 1255 ;; ELT's subdir is affected by the rename 1256 (dired-rename-subdir-2 elt dir to))) 1257 (if (equal dir default-directory) 1258 ;; if top level directory was renamed, lots of things have to be 1259 ;; updated: 1260 (progn 1261 (dired-unadvertise dir) ; we no longer dired DIR... 1262 (setq default-directory to 1263 dired-directory (expand-file-name;; this is correct 1264 ;; with and without wildcards 1265 (file-name-nondirectory dired-directory) 1266 to)) 1267 (let ((new-name (file-name-nondirectory 1268 (directory-file-name dired-directory)))) 1269 ;; try to rename buffer, but just leave old name if new 1270 ;; name would already exist (don't try appending "<%d>") 1271 (or (get-buffer new-name) 1272 (rename-buffer new-name))) 1273 ;; ... we dired TO now: 1274 (dired-advertise))))) 1275 1276(defun dired-rename-subdir-2 (elt dir to) 1277 ;; Update the headerline and dired-subdir-alist element, as well as 1278 ;; dired-switches-alist element, of directory described by 1279 ;; alist-element ELT to reflect the moving of DIR to TO. Thus, ELT 1280 ;; describes either DIR itself or a subdir of DIR. 1281 (save-excursion 1282 (let ((regexp (regexp-quote (directory-file-name dir))) 1283 (newtext (directory-file-name to)) 1284 buffer-read-only) 1285 (goto-char (dired-get-subdir-min elt)) 1286 ;; Update subdir headerline in buffer 1287 (if (not (looking-at dired-subdir-regexp)) 1288 (error "%s not found where expected - dired-subdir-alist broken?" 1289 dir) 1290 (goto-char (match-beginning 1)) 1291 (if (re-search-forward regexp (match-end 1) t) 1292 (replace-match newtext t t) 1293 (error "Expected to find `%s' in headerline of %s" dir (car elt)))) 1294 ;; Update buffer-local dired-subdir-alist and dired-switches-alist 1295 (let ((cons (assoc-string (car elt) dired-switches-alist)) 1296 (cur-dir (dired-normalize-subdir 1297 (dired-replace-in-string regexp newtext (car elt))))) 1298 (setcar elt cur-dir) 1299 (when cons (setcar cons cur-dir)))))) 1300 1301;; The basic function for half a dozen variations on cp/mv/ln/ln -s. 1302(defun dired-create-files (file-creator operation fn-list name-constructor 1303 &optional marker-char) 1304 1305;; Create a new file for each from a list of existing files. The user 1306;; is queried, dired buffers are updated, and at the end a success or 1307;; failure message is displayed 1308 1309;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists 1310 1311;; It is called for each file and must create newfile, the entry of 1312;; which will be added. The user will be queried if the file already 1313;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a 1314;; rename), it is FILE-CREATOR's responsibility to update dired 1315;; buffers. FILE-CREATOR must abort by signaling a file-error if it 1316;; could not create newfile. The error is caught and logged. 1317 1318;; OPERATION (a capitalized string, e.g. `Copy') describes the 1319;; operation performed. It is used for error logging. 1320 1321;; FN-LIST is the list of files to copy (full absolute file names). 1322 1323;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to 1324;; skip. If it skips files for other reasons than a direct user 1325;; query, it is supposed to tell why (using dired-log). 1326 1327;; Optional MARKER-CHAR is a character with which to mark every 1328;; newfile's entry, or t to use the current marker character if the 1329;; oldfile was marked. 1330 1331 (let (dired-create-files-failures failures 1332 skipped (success-count 0) (total (length fn-list))) 1333 (let (to overwrite-query 1334 overwrite-backup-query) ; for dired-handle-overwrite 1335 (mapcar 1336 (function 1337 (lambda (from) 1338 (setq to (funcall name-constructor from)) 1339 (if (equal to from) 1340 (progn 1341 (setq to nil) 1342 (dired-log "Cannot %s to same file: %s\n" 1343 (downcase operation) from))) 1344 (if (not to) 1345 (setq skipped (cons (dired-make-relative from) skipped)) 1346 (let* ((overwrite (file-exists-p to)) 1347 (dired-overwrite-confirmed ; for dired-handle-overwrite 1348 (and overwrite 1349 (let ((help-form '(format "\ 1350Type SPC or `y' to overwrite file `%s', 1351DEL or `n' to skip to next, 1352ESC or `q' to not overwrite any of the remaining files, 1353`!' to overwrite all remaining files with no more questions." to))) 1354 (dired-query 'overwrite-query 1355 "Overwrite `%s'?" to)))) 1356 ;; must determine if FROM is marked before file-creator 1357 ;; gets a chance to delete it (in case of a move). 1358 (actual-marker-char 1359 (cond ((integerp marker-char) marker-char) 1360 (marker-char (dired-file-marker from)) ; slow 1361 (t nil)))) 1362 (condition-case err 1363 (progn 1364 (funcall file-creator from to dired-overwrite-confirmed) 1365 (if overwrite 1366 ;; If we get here, file-creator hasn't been aborted 1367 ;; and the old entry (if any) has to be deleted 1368 ;; before adding the new entry. 1369 (dired-remove-file to)) 1370 (setq success-count (1+ success-count)) 1371 (message "%s: %d of %d" operation success-count total) 1372 (dired-add-file to actual-marker-char)) 1373 (file-error ; FILE-CREATOR aborted 1374 (progn 1375 (push (dired-make-relative from) 1376 failures) 1377 (dired-log "%s `%s' to `%s' failed:\n%s\n" 1378 operation from to err)))))))) 1379 fn-list)) 1380 (cond 1381 (dired-create-files-failures 1382 (setq failures (nconc failures dired-create-files-failures)) 1383 (dired-log-summary 1384 (format "%s failed for %d file%s in %d requests" 1385 operation (length failures) 1386 (dired-plural-s (length failures)) 1387 total) 1388 failures)) 1389 (failures 1390 (dired-log-summary 1391 (format "%s failed for %d of %d file%s" 1392 operation (length failures) 1393 total (dired-plural-s total)) 1394 failures)) 1395 (skipped 1396 (dired-log-summary 1397 (format "%s: %d of %d file%s skipped" 1398 operation (length skipped) total 1399 (dired-plural-s total)) 1400 skipped)) 1401 (t 1402 (message "%s: %s file%s" 1403 operation success-count (dired-plural-s success-count))))) 1404 (dired-move-to-filename)) 1405 1406(defun dired-do-create-files (op-symbol file-creator operation arg 1407 &optional marker-char op1 1408 how-to) 1409 "Create a new file for each marked file. 1410Prompts user for target, which is a directory in which to create 1411 the new files. Target may be a plain file if only one marked 1412 file exists. The way the default for the target directory is 1413 computed depends on the value of `dired-dwim-target-directory'. 1414OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' 1415 will determine whether pop-ups are appropriate for this OP-SYMBOL. 1416FILE-CREATOR and OPERATION as in `dired-create-files'. 1417ARG as in `dired-get-marked-files'. 1418Optional arg MARKER-CHAR as in `dired-create-files'. 1419Optional arg OP1 is an alternate form for OPERATION if there is 1420 only one file. 1421Optional arg HOW-TO is used to set the value of the into-dir variable 1422 which determines how to treat target. 1423 If into-dir is set to nil then target is not regarded as a directory, 1424 there must be exactly one marked file, else error. 1425 Else if into-dir is set to a list, then target is a generalized 1426 directory (e.g. some sort of archive). The first element of into-dir 1427 must be a function with at least four arguments: 1428 operation as OPERATION above. 1429 rfn-list a list of the relative names for the marked files. 1430 fn-list a list of the absolute names for the marked files. 1431 target. 1432 The rest of into-dir are optional arguments. 1433 Else into-dir is not a list. Target is a directory. 1434 The marked file(s) are created inside the target directory. 1435 1436 If HOW-TO is not given (or nil), then into-dir is set to true if 1437 target is a directory and otherwise to nil. 1438 Else if HOW-TO is t, then into-dir is set to nil. 1439 Else HOW-TO is assumed to be a function of one argument, target, 1440 that looks at target and returns a value for the into-dir 1441 variable. The function `dired-into-dir-with-symlinks' is provided 1442 for the case (common when creating symlinks) that symbolic 1443 links to directories are not to be considered as directories 1444 (as `file-directory-p' would if HOW-TO had been nil)." 1445 (or op1 (setq op1 operation)) 1446 (let* ((fn-list (dired-get-marked-files nil arg)) 1447 (rfn-list (mapcar (function dired-make-relative) fn-list)) 1448 (dired-one-file ; fluid variable inside dired-create-files 1449 (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) 1450 (target-dir (dired-dwim-target-directory)) 1451 (default (and dired-one-file 1452 (expand-file-name (file-name-nondirectory (car fn-list)) 1453 target-dir))) 1454 (target (expand-file-name ; fluid variable inside dired-create-files 1455 (dired-mark-read-file-name 1456 (concat (if dired-one-file op1 operation) " %s to: ") 1457 target-dir op-symbol arg rfn-list default))) 1458 (into-dir (cond ((null how-to) 1459 ;; Allow DOS/Windows users to change the letter 1460 ;; case of a directory. If we don't test these 1461 ;; conditions up front, file-directory-p below 1462 ;; will return t because the filesystem is 1463 ;; case-insensitive, and Emacs will try to move 1464 ;; foo -> foo/foo, which fails. 1465 (if (and (memq system-type '(ms-dos windows-nt cygwin)) 1466 (eq op-symbol 'move) 1467 dired-one-file 1468 (string= (downcase 1469 (expand-file-name (car fn-list))) 1470 (downcase 1471 (expand-file-name target))) 1472 (not (string= 1473 (file-name-nondirectory (car fn-list)) 1474 (file-name-nondirectory target)))) 1475 nil 1476 (file-directory-p target))) 1477 ((eq how-to t) nil) 1478 (t (funcall how-to target))))) 1479 (if (and (consp into-dir) (functionp (car into-dir))) 1480 (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) 1481 (if (not (or dired-one-file into-dir)) 1482 (error "Marked %s: target must be a directory: %s" operation target)) 1483 ;; rename-file bombs when moving directories unless we do this: 1484 (or into-dir (setq target (directory-file-name target))) 1485 (dired-create-files 1486 file-creator operation fn-list 1487 (if into-dir ; target is a directory 1488 ;; This function uses fluid variable target when called 1489 ;; inside dired-create-files: 1490 (function 1491 (lambda (from) 1492 (expand-file-name (file-name-nondirectory from) target))) 1493 (function (lambda (from) target))) 1494 marker-char)))) 1495 1496;; Read arguments for a marked-files command that wants a file name, 1497;; perhaps popping up the list of marked files. 1498;; ARG is the prefix arg and indicates whether the files came from 1499;; marks (ARG=nil) or a repeat factor (integerp ARG). 1500;; If the current file was used, the list has but one element and ARG 1501;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). 1502;; DEFAULT is the default value to return if the user just hits RET; 1503;; if it is omitted or nil, then the name of the directory is used. 1504 1505(defun dired-mark-read-file-name (prompt dir op-symbol arg files 1506 &optional default) 1507 (dired-mark-pop-up 1508 nil op-symbol files 1509 (function read-file-name) 1510 (format prompt (dired-mark-prompt arg files)) dir default)) 1511 1512(defun dired-dwim-target-directory () 1513 ;; Try to guess which target directory the user may want. 1514 ;; If there is a dired buffer displayed in the next window, use 1515 ;; its current subdir, else use current subdir of this dired buffer. 1516 (let ((this-dir (and (eq major-mode 'dired-mode) 1517 (dired-current-directory)))) 1518 ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode 1519 (if dired-dwim-target 1520 (let* ((other-buf (window-buffer (next-window))) 1521 (other-dir (save-excursion 1522 (set-buffer other-buf) 1523 (and (eq major-mode 'dired-mode) 1524 (dired-current-directory))))) 1525 (or other-dir this-dir)) 1526 this-dir))) 1527 1528;;;###autoload 1529(defun dired-create-directory (directory) 1530 "Create a directory called DIRECTORY." 1531 (interactive 1532 (list (read-file-name "Create directory: " (dired-current-directory)))) 1533 (let ((expanded (directory-file-name (expand-file-name directory)))) 1534 (make-directory expanded) 1535 (dired-add-file expanded) 1536 (dired-move-to-filename))) 1537 1538(defun dired-into-dir-with-symlinks (target) 1539 (and (file-directory-p target) 1540 (not (file-symlink-p target)))) 1541;; This may not always be what you want, especially if target is your 1542;; home directory and it happens to be a symbolic link, as is often the 1543;; case with NFS and automounters. Or if you want to make symlinks 1544;; into directories that themselves are only symlinks, also quite 1545;; common. 1546 1547;; So we don't use this function as value for HOW-TO in 1548;; dired-do-symlink, which has the minor disadvantage of 1549;; making links *into* a symlinked-dir, when you really wanted to 1550;; *overwrite* that symlink. In that (rare, I guess) case, you'll 1551;; just have to remove that symlink by hand before making your marked 1552;; symlinks. 1553 1554(defvar dired-copy-how-to-fn nil 1555 "nil or a function used by `dired-do-copy' to determine target. 1556See HOW-TO argument for `dired-do-create-files'.") 1557 1558;;;###autoload 1559(defun dired-do-copy (&optional arg) 1560 "Copy all marked (or next ARG) files, or copy the current file. 1561This normally preserves the last-modified date when copying. 1562When operating on just the current file, you specify the new name. 1563When operating on multiple or marked files, you specify a directory, 1564and new copies of these files are made in that directory 1565with the same names that the files currently have. The default 1566suggested for the target directory depends on the value of 1567`dired-dwim-target', which see. 1568 1569This command copies symbolic links by creating new ones, 1570like `cp -d'." 1571 (interactive "P") 1572 (let ((dired-recursive-copies dired-recursive-copies)) 1573 (dired-do-create-files 'copy (function dired-copy-file) 1574 "Copy" 1575 arg dired-keep-marker-copy 1576 nil dired-copy-how-to-fn))) 1577 1578;;;###autoload 1579(defun dired-do-symlink (&optional arg) 1580 "Make symbolic links to current file or all marked (or next ARG) files. 1581When operating on just the current file, you specify the new name. 1582When operating on multiple or marked files, you specify a directory 1583and new symbolic links are made in that directory 1584with the same names that the files currently have. The default 1585suggested for the target directory depends on the value of 1586`dired-dwim-target', which see. 1587 1588For relative symlinks, use \\[dired-do-relsymlink]." 1589 (interactive "P") 1590 (dired-do-create-files 'symlink (function make-symbolic-link) 1591 "Symlink" arg dired-keep-marker-symlink)) 1592 1593;;;###autoload 1594(defun dired-do-hardlink (&optional arg) 1595 "Add names (hard links) current file or all marked (or next ARG) files. 1596When operating on just the current file, you specify the new name. 1597When operating on multiple or marked files, you specify a directory 1598and new hard links are made in that directory 1599with the same names that the files currently have. The default 1600suggested for the target directory depends on the value of 1601`dired-dwim-target', which see." 1602 (interactive "P") 1603 (dired-do-create-files 'hardlink (function dired-hardlink) 1604 "Hardlink" arg dired-keep-marker-hardlink)) 1605 1606(defun dired-hardlink (file newname &optional ok-if-already-exists) 1607 (dired-handle-overwrite newname) 1608 ;; error is caught in -create-files 1609 (add-name-to-file file newname ok-if-already-exists) 1610 ;; Update the link count 1611 (dired-relist-file file)) 1612 1613;;;###autoload 1614(defun dired-do-rename (&optional arg) 1615 "Rename current file or all marked (or next ARG) files. 1616When renaming just the current file, you specify the new name. 1617When renaming multiple or marked files, you specify a directory. 1618This command also renames any buffers that are visiting the files. 1619The default suggested for the target directory depends on the value 1620of `dired-dwim-target', which see." 1621 (interactive "P") 1622 (dired-do-create-files 'move (function dired-rename-file) 1623 "Move" arg dired-keep-marker-rename "Rename")) 1624;;;###end dired-cp.el 1625 1626;;; 5K 1627;;;###begin dired-re.el 1628(defun dired-do-create-files-regexp 1629 (file-creator operation arg regexp newname &optional whole-name marker-char) 1630 ;; Create a new file for each marked file using regexps. 1631 ;; FILE-CREATOR and OPERATION as in dired-create-files. 1632 ;; ARG as in dired-get-marked-files. 1633 ;; Matches each marked file against REGEXP and constructs the new 1634 ;; filename from NEWNAME (like in function replace-match). 1635 ;; Optional arg WHOLE-NAME means match/replace the whole file name 1636 ;; instead of only the non-directory part of the file. 1637 ;; Optional arg MARKER-CHAR as in dired-create-files. 1638 (let* ((fn-list (dired-get-marked-files nil arg)) 1639 (fn-count (length fn-list)) 1640 (operation-prompt (concat operation " `%s' to `%s'?")) 1641 (rename-regexp-help-form (format "\ 1642Type SPC or `y' to %s one match, DEL or `n' to skip to next, 1643`!' to %s all remaining matches with no more questions." 1644 (downcase operation) 1645 (downcase operation))) 1646 (regexp-name-constructor 1647 ;; Function to construct new filename using REGEXP and NEWNAME: 1648 (if whole-name ; easy (but rare) case 1649 (function 1650 (lambda (from) 1651 (let ((to (dired-string-replace-match regexp from newname)) 1652 ;; must bind help-form directly around call to 1653 ;; dired-query 1654 (help-form rename-regexp-help-form)) 1655 (if to 1656 (and (dired-query 'rename-regexp-query 1657 operation-prompt 1658 from 1659 to) 1660 to) 1661 (dired-log "%s: %s did not match regexp %s\n" 1662 operation from regexp))))) 1663 ;; not whole-name, replace non-directory part only 1664 (function 1665 (lambda (from) 1666 (let* ((new (dired-string-replace-match 1667 regexp (file-name-nondirectory from) newname)) 1668 (to (and new ; nil means there was no match 1669 (expand-file-name new 1670 (file-name-directory from)))) 1671 (help-form rename-regexp-help-form)) 1672 (if to 1673 (and (dired-query 'rename-regexp-query 1674 operation-prompt 1675 (dired-make-relative from) 1676 (dired-make-relative to)) 1677 to) 1678 (dired-log "%s: %s did not match regexp %s\n" 1679 operation (file-name-nondirectory from) regexp))))))) 1680 rename-regexp-query) 1681 (dired-create-files 1682 file-creator operation fn-list regexp-name-constructor marker-char))) 1683 1684(defun dired-mark-read-regexp (operation) 1685 ;; Prompt user about performing OPERATION. 1686 ;; Read and return list of: regexp newname arg whole-name. 1687 (let* ((whole-name 1688 (equal 0 (prefix-numeric-value current-prefix-arg))) 1689 (arg 1690 (if whole-name nil current-prefix-arg)) 1691 (regexp 1692 (dired-read-regexp 1693 (concat (if whole-name "Abs. " "") operation " from (regexp): "))) 1694 (newname 1695 (read-string 1696 (concat (if whole-name "Abs. " "") operation " " regexp " to: ")))) 1697 (list regexp newname arg whole-name))) 1698 1699;;;###autoload 1700(defun dired-do-rename-regexp (regexp newname &optional arg whole-name) 1701 "Rename selected files whose names match REGEXP to NEWNAME. 1702 1703With non-zero prefix argument ARG, the command operates on the next ARG 1704files. Otherwise, it operates on all the marked files, or the current 1705file if none are marked. 1706 1707As each match is found, the user must type a character saying 1708 what to do with it. For directions, type \\[help-command] at that time. 1709NEWNAME may contain \\=\\<n> or \\& as in `query-replace-regexp'. 1710REGEXP defaults to the last regexp used. 1711 1712With a zero prefix arg, renaming by regexp affects the absolute file name. 1713Normally, only the non-directory part of the file name is used and changed." 1714 (interactive (dired-mark-read-regexp "Rename")) 1715 (dired-do-create-files-regexp 1716 (function dired-rename-file) 1717 "Rename" arg regexp newname whole-name dired-keep-marker-rename)) 1718 1719;;;###autoload 1720(defun dired-do-copy-regexp (regexp newname &optional arg whole-name) 1721 "Copy selected files whose names match REGEXP to NEWNAME. 1722See function `dired-do-rename-regexp' for more info." 1723 (interactive (dired-mark-read-regexp "Copy")) 1724 (let ((dired-recursive-copies nil)) ; No recursive copies. 1725 (dired-do-create-files-regexp 1726 (function dired-copy-file) 1727 (if dired-copy-preserve-time "Copy [-p]" "Copy") 1728 arg regexp newname whole-name dired-keep-marker-copy))) 1729 1730;;;###autoload 1731(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-name) 1732 "Hardlink selected files whose names match REGEXP to NEWNAME. 1733See function `dired-do-rename-regexp' for more info." 1734 (interactive (dired-mark-read-regexp "HardLink")) 1735 (dired-do-create-files-regexp 1736 (function add-name-to-file) 1737 "HardLink" arg regexp newname whole-name dired-keep-marker-hardlink)) 1738 1739;;;###autoload 1740(defun dired-do-symlink-regexp (regexp newname &optional arg whole-name) 1741 "Symlink selected files whose names match REGEXP to NEWNAME. 1742See function `dired-do-rename-regexp' for more info." 1743 (interactive (dired-mark-read-regexp "SymLink")) 1744 (dired-do-create-files-regexp 1745 (function make-symbolic-link) 1746 "SymLink" arg regexp newname whole-name dired-keep-marker-symlink)) 1747 1748(defun dired-create-files-non-directory 1749 (file-creator basename-constructor operation arg) 1750 ;; Perform FILE-CREATOR on the non-directory part of marked files 1751 ;; using function BASENAME-CONSTRUCTOR, with query for each file. 1752 ;; OPERATION like in dired-create-files, ARG as in dired-get-marked-files. 1753 (let (rename-non-directory-query) 1754 (dired-create-files 1755 file-creator 1756 operation 1757 (dired-get-marked-files nil arg) 1758 (function 1759 (lambda (from) 1760 (let ((to (concat (file-name-directory from) 1761 (funcall basename-constructor 1762 (file-name-nondirectory from))))) 1763 (and (let ((help-form (format "\ 1764Type SPC or `y' to %s one file, DEL or `n' to skip to next, 1765`!' to %s all remaining matches with no more questions." 1766 (downcase operation) 1767 (downcase operation)))) 1768 (dired-query 'rename-non-directory-query 1769 (concat operation " `%s' to `%s'") 1770 (dired-make-relative from) 1771 (dired-make-relative to))) 1772 to)))) 1773 dired-keep-marker-rename))) 1774 1775(defun dired-rename-non-directory (basename-constructor operation arg) 1776 (dired-create-files-non-directory 1777 (function dired-rename-file) 1778 basename-constructor operation arg)) 1779 1780;;;###autoload 1781(defun dired-upcase (&optional arg) 1782 "Rename all marked (or next ARG) files to upper case." 1783 (interactive "P") 1784 (dired-rename-non-directory (function upcase) "Rename upcase" arg)) 1785 1786;;;###autoload 1787(defun dired-downcase (&optional arg) 1788 "Rename all marked (or next ARG) files to lower case." 1789 (interactive "P") 1790 (dired-rename-non-directory (function downcase) "Rename downcase" arg)) 1791 1792;;;###end dired-re.el 1793 1794;;; 13K 1795;;;###begin dired-ins.el 1796 1797;;;###autoload 1798(defun dired-maybe-insert-subdir (dirname &optional 1799 switches no-error-if-not-dir-p) 1800 "Insert this subdirectory into the same dired buffer. 1801If it is already present, just move to it (type \\[dired-do-redisplay] to refresh), 1802 else inserts it at its natural place (as `ls -lR' would have done). 1803With a prefix arg, you may edit the ls switches used for this listing. 1804 You can add `R' to the switches to expand the whole tree starting at 1805 this subdirectory. 1806This function takes some pains to conform to `ls -lR' output. 1807 1808Dired remembers switches specified with a prefix arg, so that reverting 1809the buffer will not reset them. However, using `dired-undo' to re-insert 1810or delete subdirectories can bypass this machinery. Hence, you sometimes 1811may have to reset some subdirectory switches after a `dired-undo'. 1812You can reset all subdirectory switches to the default using 1813\\<dired-mode-map>\\[dired-reset-subdir-switches]. 1814See Info node `(emacs)Subdir switches' for more details." 1815 (interactive 1816 (list (dired-get-filename) 1817 (if current-prefix-arg 1818 (read-string "Switches for listing: " 1819 (or dired-subdir-switches dired-actual-switches))))) 1820 (let ((opoint (point))) 1821 ;; We don't need a marker for opoint as the subdir is always 1822 ;; inserted *after* opoint. 1823 (setq dirname (file-name-as-directory dirname)) 1824 (or (and (not switches) 1825 (dired-goto-subdir dirname)) 1826 (dired-insert-subdir dirname switches no-error-if-not-dir-p)) 1827 ;; Push mark so that it's easy to find back. Do this after the 1828 ;; insert message so that the user sees the `Mark set' message. 1829 (push-mark opoint))) 1830 1831;;;###autoload 1832(defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) 1833 "Insert this subdirectory into the same dired buffer. 1834If it is already present, overwrites previous entry, 1835 else inserts it at its natural place (as `ls -lR' would have done). 1836With a prefix arg, you may edit the `ls' switches used for this listing. 1837 You can add `R' to the switches to expand the whole tree starting at 1838 this subdirectory. 1839This function takes some pains to conform to `ls -lR' output." 1840 ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like 1841 ;; Prospero where dired-ls does the right thing, but 1842 ;; file-directory-p has not been redefined. 1843 (interactive 1844 (list (dired-get-filename) 1845 (if current-prefix-arg 1846 (read-string "Switches for listing: " 1847 (or dired-subdir-switches dired-actual-switches))))) 1848 (setq dirname (file-name-as-directory (expand-file-name dirname))) 1849 (or no-error-if-not-dir-p 1850 (file-directory-p dirname) 1851 (error "Attempt to insert a non-directory: %s" dirname)) 1852 (let ((elt (assoc dirname dired-subdir-alist)) 1853 (cons (assoc-string dirname dired-switches-alist)) 1854 (modflag (buffer-modified-p)) 1855 (old-switches switches) 1856 switches-have-R mark-alist case-fold-search buffer-read-only) 1857 (and (not switches) cons (setq switches (cdr cons))) 1858 (dired-insert-subdir-validate dirname switches) 1859 ;; case-fold-search is nil now, so we can test for capital `R': 1860 (if (setq switches-have-R (and switches (string-match "R" switches))) 1861 ;; avoid duplicated subdirs 1862 (setq mark-alist (dired-kill-tree dirname t))) 1863 (if elt 1864 ;; If subdir is already present, remove it and remember its marks 1865 (setq mark-alist (nconc (dired-insert-subdir-del elt) mark-alist)) 1866 (dired-insert-subdir-newpos dirname)) ; else compute new position 1867 (dired-insert-subdir-doupdate 1868 dirname elt (dired-insert-subdir-doinsert dirname switches)) 1869 (when old-switches 1870 (if cons 1871 (setcdr cons switches) 1872 (push (cons dirname switches) dired-switches-alist))) 1873 (when switches-have-R 1874 (dired-build-subdir-alist switches) 1875 (setq switches (dired-replace-in-string "R" "" switches)) 1876 (dolist (cur-ass dired-subdir-alist) 1877 (let ((cur-dir (car cur-ass))) 1878 (and (dired-in-this-tree cur-dir dirname) 1879 (let ((cur-cons (assoc-string cur-dir dired-switches-alist))) 1880 (if cur-cons 1881 (setcdr cur-cons switches) 1882 (push (cons cur-dir switches) dired-switches-alist))))))) 1883 (dired-initial-position dirname) 1884 (save-excursion (dired-mark-remembered mark-alist)) 1885 (restore-buffer-modified-p modflag))) 1886 1887;; This is a separate function for dired-vms. 1888(defun dired-insert-subdir-validate (dirname &optional switches) 1889 ;; Check that it is valid to insert DIRNAME with SWITCHES. 1890 ;; Signal an error if invalid (e.g. user typed `i' on `..'). 1891 (or (dired-in-this-tree dirname (expand-file-name default-directory)) 1892 (error "%s: not in this directory tree" dirname)) 1893 (let ((real-switches (or switches dired-subdir-switches))) 1894 (when real-switches 1895 (let (case-fold-search) 1896 (mapcar 1897 (function 1898 (lambda (x) 1899 (or (eq (null (string-match x real-switches)) 1900 (null (string-match x dired-actual-switches))) 1901 (error 1902 "Can't have dirs with and without -%s switches together" x)))) 1903 ;; all switches that make a difference to dired-get-filename: 1904 '("F" "b")))))) 1905 1906(defun dired-alist-add (dir new-marker) 1907 ;; Add new DIR at NEW-MARKER. Sort alist. 1908 (dired-alist-add-1 dir new-marker) 1909 (dired-alist-sort)) 1910 1911(defun dired-alist-sort () 1912 ;; Keep the alist sorted on buffer position. 1913 (setq dired-subdir-alist 1914 (sort dired-subdir-alist 1915 (function (lambda (elt1 elt2) 1916 (> (dired-get-subdir-min elt1) 1917 (dired-get-subdir-min elt2))))))) 1918 1919(defun dired-kill-tree (dirname &optional remember-marks kill-root) 1920 "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. 1921Interactively, you can kill DIRNAME as well by using a prefix argument. 1922In interactive use, the command prompts for DIRNAME. 1923 1924When called from Lisp, if REMEMBER-MARKS is non-nil, return an alist 1925of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." 1926 (interactive "DKill tree below directory: \ni\nP") 1927 (setq dirname (file-name-as-directory (expand-file-name dirname))) 1928 (let ((s-alist dired-subdir-alist) dir m-alist) 1929 (while s-alist 1930 (setq dir (car (car s-alist)) 1931 s-alist (cdr s-alist)) 1932 (and (or kill-root (not (string-equal dir dirname))) 1933 (dired-in-this-tree dir dirname) 1934 (dired-goto-subdir dir) 1935 (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) 1936 m-alist)) 1937 1938(defun dired-insert-subdir-newpos (new-dir) 1939 ;; Find pos for new subdir, according to tree order. 1940 ;;(goto-char (point-max)) 1941 (let ((alist dired-subdir-alist) elt dir pos new-pos) 1942 (while alist 1943 (setq elt (car alist) 1944 alist (cdr alist) 1945 dir (car elt) 1946 pos (dired-get-subdir-min elt)) 1947 (if (dired-tree-lessp dir new-dir) 1948 ;; Insert NEW-DIR after DIR 1949 (setq new-pos (dired-get-subdir-max elt) 1950 alist nil))) 1951 (goto-char new-pos)) 1952 ;; want a separating newline between subdirs 1953 (or (eobp) 1954 (forward-line -1)) 1955 (insert "\n") 1956 (point)) 1957 1958(defun dired-insert-subdir-del (element) 1959 ;; Erase an already present subdir (given by ELEMENT) from buffer. 1960 ;; Move to that buffer position. Return a mark-alist. 1961 (let ((begin-marker (dired-get-subdir-min element))) 1962 (goto-char begin-marker) 1963 ;; Are at beginning of subdir (and inside it!). Now determine its end: 1964 (goto-char (dired-subdir-max)) 1965 (or (eobp);; want a separating newline _between_ subdirs: 1966 (forward-char -1)) 1967 (prog1 1968 (dired-remember-marks begin-marker (point)) 1969 (delete-region begin-marker (point))))) 1970 1971(defun dired-insert-subdir-doinsert (dirname switches) 1972 ;; Insert ls output after point. 1973 ;; Return the boundary of the inserted text (as list of BEG and END). 1974 (save-excursion 1975 (let ((begin (point))) 1976 (let ((dired-actual-switches 1977 (or switches 1978 dired-subdir-switches 1979 (dired-replace-in-string "R" "" dired-actual-switches)))) 1980 (if (equal dirname (car (car (last dired-subdir-alist)))) 1981 ;; If doing the top level directory of the buffer, 1982 ;; redo it as specified in dired-directory. 1983 (dired-readin-insert) 1984 (dired-insert-directory dirname dired-actual-switches nil nil t))) 1985 (list begin (point))))) 1986 1987(defun dired-insert-subdir-doupdate (dirname elt beg-end) 1988 ;; Point is at the correct subdir alist position for ELT, 1989 ;; BEG-END is the subdir-region (as list of begin and end). 1990 (if elt ; subdir was already present 1991 ;; update its position (should actually be unchanged) 1992 (set-marker (dired-get-subdir-min elt) (point-marker)) 1993 (dired-alist-add dirname (point-marker))) 1994 ;; The hook may depend on the subdir-alist containing the just 1995 ;; inserted subdir, so run it after dired-alist-add: 1996 (if dired-after-readin-hook 1997 (save-excursion 1998 (let ((begin (nth 0 beg-end)) 1999 (end (nth 1 beg-end))) 2000 (goto-char begin) 2001 (save-restriction 2002 (narrow-to-region begin end) 2003 ;; hook may add or delete lines, but the subdir boundary 2004 ;; marker floats 2005 (run-hooks 'dired-after-readin-hook)))))) 2006 2007(defun dired-tree-lessp (dir1 dir2) 2008 ;; Lexicographic order on file name components, like `ls -lR': 2009 ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, 2010 ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, 2011 ;; or DIR1 and DIR2 are in the same parentdir and their last 2012 ;; components are string-lessp. 2013 ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. 2014 ;; string-lessp could arguably be replaced by file-newer-than-file-p 2015 ;; if dired-actual-switches contained `t'. 2016 (setq dir1 (file-name-as-directory dir1) 2017 dir2 (file-name-as-directory dir2)) 2018 (let ((components-1 (dired-split "/" dir1)) 2019 (components-2 (dired-split "/" dir2))) 2020 (while (and components-1 2021 components-2 2022 (equal (car components-1) (car components-2))) 2023 (setq components-1 (cdr components-1) 2024 components-2 (cdr components-2))) 2025 (let ((c1 (car components-1)) 2026 (c2 (car components-2))) 2027 2028 (cond ((and c1 c2) 2029 (string-lessp c1 c2)) 2030 ((and (null c1) (null c2)) 2031 nil) ; they are equal, not lessp 2032 ((null c1) ; c2 is a subdir of c1: c1<c2 2033 t) 2034 ((null c2) ; c1 is a subdir of c2: c1>c2 2035 nil) 2036 (t (error "This can't happen")))))) 2037 2038;; There should be a builtin split function - inverse to mapconcat. 2039(defun dired-split (pat str &optional limit) 2040 "Splitting on regexp PAT, turn string STR into a list of substrings. 2041Optional third arg LIMIT (>= 1) is a limit to the length of the 2042resulting list. 2043Thus, if SEP is a regexp that only matches itself, 2044 2045 (mapconcat 'identity (dired-split SEP STRING) SEP) 2046 2047is always equal to STRING." 2048 (let* ((start (string-match pat str)) 2049 (result (list (substring str 0 start))) 2050 (count 1) 2051 (end (if start (match-end 0)))) 2052 (if end ; else nothing left 2053 (while (and (or (not (integerp limit)) 2054 (< count limit)) 2055 (string-match pat str end)) 2056 (setq start (match-beginning 0) 2057 count (1+ count) 2058 result (cons (substring str end start) result) 2059 end (match-end 0) 2060 start end) 2061 )) 2062 (if (and (or (not (integerp limit)) 2063 (< count limit)) 2064 end) ; else nothing left 2065 (setq result 2066 (cons (substring str end) result))) 2067 (nreverse result))) 2068 2069;;; moving by subdirectories 2070 2071;;;###autoload 2072(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) 2073 "Go to previous subdirectory, regardless of level. 2074When called interactively and not on a subdir line, go to this subdir's line." 2075 ;;(interactive "p") 2076 (interactive 2077 (list (if current-prefix-arg 2078 (prefix-numeric-value current-prefix-arg) 2079 ;; if on subdir start already, don't stay there! 2080 (if (dired-get-subdir) 1 0)))) 2081 (dired-next-subdir (- arg) no-error-if-not-found no-skip)) 2082 2083(defun dired-subdir-min () 2084 (save-excursion 2085 (if (not (dired-prev-subdir 0 t t)) 2086 (error "Not in a subdir!") 2087 (point)))) 2088 2089;;;###autoload 2090(defun dired-goto-subdir (dir) 2091 "Go to end of header line of DIR in this dired buffer. 2092Return value of point on success, otherwise return nil. 2093The next char is either \\n, or \\r if DIR is hidden." 2094 (interactive 2095 (prog1 ; let push-mark display its message 2096 (list (expand-file-name 2097 (completing-read "Goto in situ directory: " ; prompt 2098 dired-subdir-alist ; table 2099 nil ; predicate 2100 t ; require-match 2101 (dired-current-directory)))) 2102 (push-mark))) 2103 (setq dir (file-name-as-directory dir)) 2104 (let ((elt (assoc dir dired-subdir-alist))) 2105 (and elt 2106 (goto-char (dired-get-subdir-min elt)) 2107 ;; dired-subdir-hidden-p and dired-add-entry depend on point being 2108 ;; at either \r or \n after this function succeeds. 2109 (progn (skip-chars-forward "^\r\n") 2110 (point))))) 2111 2112;;;###autoload 2113(defun dired-mark-subdir-files () 2114 "Mark all files except `.' and `..' in current subdirectory. 2115If the Dired buffer shows multiple directories, this command 2116marks the files listed in the subdirectory that point is in." 2117 (interactive) 2118 (let ((p-min (dired-subdir-min))) 2119 (dired-mark-files-in-region p-min (dired-subdir-max)))) 2120 2121;;;###autoload 2122(defun dired-kill-subdir (&optional remember-marks) 2123 "Remove all lines of current subdirectory. 2124Lower levels are unaffected." 2125 ;; With optional REMEMBER-MARKS, return a mark-alist. 2126 (interactive) 2127 (let* ((beg (dired-subdir-min)) 2128 (end (dired-subdir-max)) 2129 (modflag (buffer-modified-p)) 2130 (cur-dir (dired-current-directory)) 2131 (cons (assoc-string cur-dir dired-switches-alist)) 2132 buffer-read-only) 2133 (if (equal cur-dir default-directory) 2134 (error "Attempt to kill top level directory")) 2135 (prog1 2136 (if remember-marks (dired-remember-marks beg end)) 2137 (delete-region beg end) 2138 (if (eobp) ; don't leave final blank line 2139 (delete-char -1)) 2140 (dired-unsubdir cur-dir) 2141 (when cons 2142 (setq dired-switches-alist (delete cons dired-switches-alist))) 2143 (restore-buffer-modified-p modflag)))) 2144 2145(defun dired-unsubdir (dir) 2146 ;; Remove DIR from the alist 2147 (setq dired-subdir-alist 2148 (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) 2149 2150;;;###autoload 2151(defun dired-tree-up (arg) 2152 "Go up ARG levels in the dired tree." 2153 (interactive "p") 2154 (let ((dir (dired-current-directory))) 2155 (while (>= arg 1) 2156 (setq arg (1- arg) 2157 dir (file-name-directory (directory-file-name dir)))) 2158 ;;(setq dir (expand-file-name dir)) 2159 (or (dired-goto-subdir dir) 2160 (error "Cannot go up to %s - not in this tree" dir)))) 2161 2162;;;###autoload 2163(defun dired-tree-down () 2164 "Go down in the dired tree." 2165 (interactive) 2166 (let ((dir (dired-current-directory)) ; has slash 2167 pos case-fold-search) ; filenames are case sensitive 2168 (let ((rest (reverse dired-subdir-alist)) elt) 2169 (while rest 2170 (setq elt (car rest) 2171 rest (cdr rest)) 2172 (if (dired-in-this-tree (directory-file-name (car elt)) dir) 2173 (setq rest nil 2174 pos (dired-goto-subdir (car elt)))))) 2175 (if pos 2176 (goto-char pos) 2177 (error "At the bottom")))) 2178 2179;;; hiding 2180 2181(defun dired-unhide-subdir () 2182 (let (buffer-read-only) 2183 (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n))) 2184 2185(defun dired-hide-check () 2186 (or selective-display 2187 (error "selective-display must be t for subdir hiding to work!"))) 2188 2189(defun dired-subdir-hidden-p (dir) 2190 (and selective-display 2191 (save-excursion 2192 (dired-goto-subdir dir) 2193 (looking-at "\r")))) 2194 2195;;;###autoload 2196(defun dired-hide-subdir (arg) 2197 "Hide or unhide the current subdirectory and move to next directory. 2198Optional prefix arg is a repeat factor. 2199Use \\[dired-hide-all] to (un)hide all directories." 2200 (interactive "p") 2201 (dired-hide-check) 2202 (let ((modflag (buffer-modified-p))) 2203 (while (>= (setq arg (1- arg)) 0) 2204 (let* ((cur-dir (dired-current-directory)) 2205 (hidden-p (dired-subdir-hidden-p cur-dir)) 2206 (elt (assoc cur-dir dired-subdir-alist)) 2207 (end-pos (1- (dired-get-subdir-max elt))) 2208 buffer-read-only) 2209 ;; keep header line visible, hide rest 2210 (goto-char (dired-get-subdir-min elt)) 2211 (skip-chars-forward "^\n\r") 2212 (if hidden-p 2213 (subst-char-in-region (point) end-pos ?\r ?\n) 2214 (subst-char-in-region (point) end-pos ?\n ?\r))) 2215 (dired-next-subdir 1 t)) 2216 (restore-buffer-modified-p modflag))) 2217 2218;;;###autoload 2219(defun dired-hide-all (arg) 2220 "Hide all subdirectories, leaving only their header lines. 2221If there is already something hidden, make everything visible again. 2222Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." 2223 (interactive "P") 2224 (dired-hide-check) 2225 (let ((modflag (buffer-modified-p)) 2226 buffer-read-only) 2227 (if (save-excursion 2228 (goto-char (point-min)) 2229 (search-forward "\r" nil t)) 2230 ;; unhide - bombs on \r in filenames 2231 (subst-char-in-region (point-min) (point-max) ?\r ?\n) 2232 ;; hide 2233 (let ((pos (point-max)) ; pos of end of last directory 2234 (alist dired-subdir-alist)) 2235 (while alist ; while there are dirs before pos 2236 (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir 2237 (save-excursion 2238 (goto-char pos) ; current dir 2239 ;; we're somewhere on current dir's line 2240 (forward-line -1) 2241 (point)) 2242 ?\n ?\r) 2243 (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir 2244 (setq alist (cdr alist))))) 2245 (restore-buffer-modified-p modflag))) 2246 2247;;;###end dired-ins.el 2248 2249 2250;; Functions for searching in tags style among marked files. 2251 2252;;;###autoload 2253(defun dired-do-search (regexp) 2254 "Search through all marked files for a match for REGEXP. 2255Stops when a match is found. 2256To continue searching for next match, use command \\[tags-loop-continue]." 2257 (interactive "sSearch marked files (regexp): ") 2258 (tags-search regexp '(dired-get-marked-files nil nil 'dired-nondirectory-p))) 2259 2260;;;###autoload 2261(defun dired-do-query-replace-regexp (from to &optional delimited) 2262 "Do `query-replace-regexp' of FROM with TO, on all marked files. 2263Third arg DELIMITED (prefix arg) means replace only word-delimited matches. 2264If you exit (\\[keyboard-quit], RET or q), you can resume the query replace 2265with the command \\[tags-loop-continue]." 2266 (interactive 2267 (let ((common 2268 (query-replace-read-args 2269 "Query replace regexp in marked files" t t))) 2270 (list (nth 0 common) (nth 1 common) (nth 2 common)))) 2271 (dolist (file (dired-get-marked-files nil nil 'dired-nondirectory-p)) 2272 (let ((buffer (get-file-buffer file))) 2273 (if (and buffer (with-current-buffer buffer 2274 buffer-read-only)) 2275 (error "File `%s' is visited read-only" file)))) 2276 (tags-query-replace from to delimited 2277 '(dired-get-marked-files nil nil 'dired-nondirectory-p))) 2278 2279(defun dired-nondirectory-p (file) 2280 (not (file-directory-p file))) 2281 2282;;;###autoload 2283(defun dired-show-file-type (file &optional deref-symlinks) 2284 "Print the type of FILE, according to the `file' command. 2285If FILE is a symbolic link and the optional argument DEREF-SYMLINKS is 2286true then the type of the file linked to by FILE is printed instead." 2287 (interactive (list (dired-get-filename t) current-prefix-arg)) 2288 (with-temp-buffer 2289 (if deref-symlinks 2290 (call-process "file" nil t t "-L" "--" file) 2291 (call-process "file" nil t t "--" file)) 2292 (when (bolp) 2293 (backward-delete-char 1)) 2294 (message "%s" (buffer-string)))) 2295 2296(provide 'dired-aux) 2297 2298;;; arch-tag: 4b508de9-a153-423d-8d3f-a1bbd86f4f60 2299;;; dired-aux.el ends here 2300