X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/6eaebaa27883a013a7b948e2b6e14dd8617dede5..8e735883f4696be337577300537480fe64f11fdf:/lisp/dired-aux.el diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 6cfcbc6759..1edbd3a1de 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1,6 +1,6 @@ -;;; dired-aux.el --- all of dired except what people usually use +;;; dired-aux.el --- less commonly used parts of dired -*-byte-compile-dynamic: t;-*- -;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1986, 1992, 1994 Free Software Foundation, Inc. ;; Author: Sebastian Kremer . @@ -110,18 +110,22 @@ With prefix arg, prompt for argument SWITCHES which is options for `diff'." "Change the mode of the marked (or next ARG) files. This calls chmod, thus symbolic modes like `g+w' are allowed." (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) + (dired-do-chxxx "Mode" dired-chmod-program 'chmod arg)) ;;;###autoload (defun dired-do-chgrp (&optional arg) "Change the group of the marked (or next ARG) files." (interactive "P") + (if (memq system-type '(ms-dos windows-nt)) + (error "chgrp not supported on this system.")) (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) ;;;###autoload (defun dired-do-chown (&optional arg) "Change the owner of the marked (or next ARG) files." (interactive "P") + (if (memq system-type '(ms-dos windows-nt)) + (error "chown not supported on this system.")) (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) ;; Process all the files in FILES in batches of a convenient size, @@ -164,7 +168,12 @@ Uses the shell command coming from variables `lpr-command' and (let* ((file-list (dired-get-marked-files t arg)) (command (dired-mark-read-string "Print %s with: " - (apply 'concat lpr-command " " lpr-switches) + (mapconcat 'identity + (cons lpr-command + (if (stringp lpr-switches) + (list lpr-switches) + lpr-switches)) + " ") 'print arg file-list))) (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))) @@ -245,19 +254,24 @@ with a prefix argument." (forward-line 1))))) (defun dired-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar 'backup-extract-version possibilities))) - (if versions - (setq dired-file-version-alist (cons (cons fn versions) - dired-file-version-alist))))) + (let ((fn (file-name-sans-versions fn))) + ;; Only do work if this file is not already in the alist. + (if (assoc fn dired-file-version-alist) + nil + ;; If it looks like file FN has versions, return a list of the versions. + ;;That is a list of strings which are file names. + ;;The caller may want to flag some of these files for deletion. + (let* ((base-versions + (concat (file-name-nondirectory fn) ".~")) + (bv-length (length base-versions)) + (possibilities (file-name-all-completions + base-versions + (file-name-directory fn))) + (versions (mapcar 'backup-extract-version possibilities))) + (if versions + (setq dired-file-version-alist + (cons (cons fn versions) + dired-file-version-alist))))))) (defun dired-trample-file-versions (fn) (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) @@ -294,7 +308,8 @@ with a prefix argument." (dired-mark-pop-up nil 'shell files (function read-string) - (format prompt (dired-mark-prompt arg files)))) + (format prompt (dired-mark-prompt arg files)) + nil 'shell-command-history)) ;; The in-background argument is only needed in Emacs 18 where ;; shell-command doesn't understand an appended ampersand `&'. @@ -628,15 +643,14 @@ and use this command with a prefix argument (the value does not matter)." (defun dired-byte-compile () ;; Return nil for success, offending file name else. (let* ((filename (dired-get-filename)) - (elc-file - (if (eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c") - (concat filename "c"))) - buffer-read-only failure) + elc-file buffer-read-only failure) (condition-case err (save-excursion (byte-compile-file filename)) (error (setq failure err))) + (setq elc-file (byte-compile-dest-file filename)) + (or (file-exists-p elc-file) + (setq failure t)) (if failure (progn (dired-log "Byte compile error for %s:\n%s\n" filename failure) @@ -682,6 +696,8 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (if arg (read-string "Switches for listing: " dired-actual-switches))) (message "Redisplaying...") ;; message much faster than making dired-map-over-marks show progress + (dired-uncache + (if (consp dired-directory) (car dired-directory) dired-directory)) (dired-map-over-marks (let ((fname (dired-get-filename))) (message "Redisplaying... %s" fname) (dired-update-file-line fname)) @@ -710,7 +726,7 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (defun dired-fun-in-all-buffers (directory fun &rest args) ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let ((buf-list (dired-buffers-for-dir directory)) + (let ((buf-list (dired-buffers-for-dir (expand-file-name directory))) (obuf (current-buffer)) buf success-list) (while buf-list @@ -742,6 +758,7 @@ a prefix arg lets you edit the `ls' switches used for the new listing." ;; Entry is always for files, even if they happen to also be directories (let ((opoint (point)) (cur-dir (dired-current-directory)) + (orig-file-name filename) (directory (file-name-directory filename)) reason) (setq filename (file-name-nondirectory filename) @@ -776,6 +793,20 @@ a prefix arg lets you edit the `ls' switches used for the new listing." (let ((default-directory directory)) (insert-directory filename (concat dired-actual-switches "d"))) + ;; Compensate for a bug in ange-ftp. + ;; It inserts the file's absolute name, rather than + ;; the relative one. That may be hard to fix since it + ;; is probably controlled by something in ftp. + (goto-char opoint) + (let ((inserted-name (dired-get-filename 'no-dir))) + (if (file-name-directory inserted-name) + (progn + (end-of-line) + (delete-char (- (length inserted-name))) + (insert filename) + (forward-char 1)) + (forward-line 1))) + ;; Give each line a text property recording info about it. (dired-insert-set-properties opoint (point)) (forward-line -1) (if dired-after-readin-hook;; the subdir-alist is not affected... @@ -894,12 +925,13 @@ Special value `always' suppresses confirmation.") (dired-fun-in-all-buffers from-dir (function dired-rename-subdir-1) from-dir to-dir) ;; Update visited file name of all affected buffers - (let ((blist (buffer-list))) + (let ((expanded-from-dir (expand-file-name from-dir)) + (blist (buffer-list))) (while blist (save-excursion - (set-buffer (car blist)) + (set-buffer (car blist)) (if (and buffer-file-name - (dired-in-this-tree buffer-file-name from-dir)) + (dired-in-this-tree buffer-file-name expanded-from-dir)) (let ((modflag (buffer-modified-p)) (to-file (dired-replace-in-string (concat "^" (regexp-quote from-dir)) @@ -912,12 +944,13 @@ Special value `always' suppresses confirmation.") (defun dired-rename-subdir-1 (dir to) ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or ;; one of its subdirectories is expanded in this buffer. - (let ((alist dired-subdir-alist) + (let ((expanded-dir (expand-file-name dir)) + (alist dired-subdir-alist) (elt nil)) (while alist (setq elt (car alist) alist (cdr alist)) - (if (dired-in-this-tree (car elt) dir) + (if (dired-in-this-tree (car elt) expanded-dir) ;; ELT's subdir is affected by the rename (dired-rename-subdir-2 elt dir to))) (if (equal dir default-directory) @@ -961,69 +994,6 @@ Special value `always' suppresses confirmation.") (dired-normalize-subdir (dired-replace-in-string regexp newtext (car elt))))))) -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -;;;###autoload -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If it does not match, nil is returned instead of the new string. -Optional arg LITERAL means to take NEWTEXT literally. -Optional arg GLOBAL means to replace all matches." - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - ;; The basic function for half a dozen variations on cp/mv/ln/ln -s. (defun dired-create-files (file-creator operation fn-list name-constructor &optional marker-char) @@ -1038,7 +1008,7 @@ Optional arg GLOBAL means to replace all matches." ;; which will be added. The user will be queried if the file already ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a ;; rename), it is FILE-CREATOR's responsibility to update dired -;; buffers. FILE-CREATOR must abort by signalling a file-error if it +;; buffers. FILE-CREATOR must abort by signaling a file-error if it ;; could not create newfile. The error is caught and logged. ;; OPERATION (a capitalized string, e.g. `Copy') describes the @@ -1232,8 +1202,8 @@ ESC or `q' to not overwrite any of the remaining files, "Copy all marked (or next ARG) files, or copy the current file. This normally preserves the last-modified date when copying. When operating on just the current file, you specify the new name. -When operating on multiple or marked files, you specify a directory -and new symbolic links are made in that directory +When operating on multiple or marked files, you specify a directory, +and new copies of these files are made in that directory with the same names that the files currently have." (interactive "P") (dired-do-create-files 'copy (function dired-copy-file) @@ -1533,6 +1503,7 @@ This function takes some pains to conform to `ls -lR' output." ;;"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. ;; With optional arg REMEMBER-MARKS, return an alist of marked files." (interactive "DKill tree below directory: ") + (setq dirname (expand-file-name dirname)) (let ((s-alist dired-subdir-alist) dir m-alist) (while s-alist (setq dir (car (car s-alist)) @@ -1733,7 +1704,7 @@ The next char is either \\n, or \\r if DIR is hidden." ;;;###autoload (defun dired-mark-subdir-files () "Mark all files except `.' and `..'." - (interactive "P") + (interactive) (let ((p-min (dired-subdir-min))) (dired-mark-files-in-region p-min (dired-subdir-max)))) @@ -1856,4 +1827,28 @@ Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." ;;;###end dired-ins.el + +;; Functions for searching in tags style among marked files. + +;;;###autoload +(defun dired-do-search (regexp) + "Search through all marked files for a match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]." + (interactive "sSearch marked files (regexp): ") + (tags-search regexp '(dired-get-marked-files))) + +;;;###autoload +(defun dired-do-query-replace (from to &optional delimited) + "Do `query-replace-regexp' of FROM with TO, on all marked files. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query replace +with the command \\[tags-loop-continue]." + (interactive + "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") + (tags-query-replace from to delimited '(dired-get-marked-files))) + + +(provide 'dired-aux) + ;;; dired-aux.el ends here