Mercurial > hg > xemacs-beta

comparison lisp/dired/dired-cd.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; -*- Mode: Emacs-lisp -*- ;;;
2 ;;; dired-cd.el - Adjust Working Directory for Tree Dired Shell Commands
3 ;;; Id: dired-cd.el,v 1.14 1991/11/01 14:28:27 sk RelBeta
4 ;;; Copyright (C) 1991 Hugh Secker-Walker
5 ;;;
6 ;;; Author: Hugh Secker-Walker hugh@ear-ache.mit.edu
7 ;;;
8 ;;; Modified by Sebastian Kremer <sk@thp.uni-koeln.de>
9 ;;;
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 1, or (at your option)
13 ;;; any later version.
14 ;;;
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
19 ;;;
20 ;;; A copy of the GNU General Public License can be obtained from this
21 ;;; program's author (send electronic mail to the above address) or from
22 ;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;; LISPDIR ENTRY for the Elisp Archive ===============================
25 ;; LCD Archive Entry:
26 ;; dired-cd|Hugh Secker-Walker|hugh@ear-ache.mit.edu
27 ;; |Adjust Working Directory for Tree Dired Shell Commands
28 ;; |Date: 1991/11/01 14:28:27 |Revision: 1.14 |
29
30 ;;; SUMMARY
31
32 ;;; This extension to Sebastian Kremer's (sk@thp.Uni-Koeln.DE) Tree-Dired
33 ;;; permits the working directory of the dired shell commands
34 ;;; dired-do-shell-command and dired-do-background-shell-command
35 ;;; to be the files' subdirectory under certain circumstances.
36 ;;; Loading this extension does not change the behavior of dired until
37 ;;; the variables dired-cd-same-subdir and/or dired-cd-on-each are
38 ;;; non-nil.
39
40
41 ;;; FUNCTIONALITY PROVIDED
42
43 ;;; If dired-cd-same-subdir is non-nil and if all the selected files
44 ;;; (marked, non-zero numeric ARG, etc.) are in the same directory, then
45 ;;; dired-do-shell-command and dired-do-background-shell-command will
46 ;;; cause the shell to perform a cd into that directory before the
47 ;;; commands are executed. Also, the selected filenames will be provided
48 ;;; to the command without any directory components.
49
50 ;;; If dired-cd-on-each is non-nil and if the on-each option is specified
51 ;;; (numeric arg of zero), then dired-do-shell-command and
52 ;;; dired-do-background-shell-command will perform a cd into the
53 ;;; directory of each file before the commands on that file are executed.
54 ;;; Also, each filename will be provided to the command without any
55 ;;; directory components. Note that this on-each behavior occurs
56 ;;; regardless of whether the files are all in the same directory or not.
57
58 ;;; After the above "cd wrapping" has occured, the existing
59 ;;; dired-shell-stuff-it is used to do file-name substitution and
60 ;;; quoting, so custom versions of this procedure should work, e.g.
61 ;;; dired-trans will transform commands correctly. However, since
62 ;;; filenames lack any directory components, features that use the
63 ;;; directory components will fail, e.g. the dired-trans [d] transform
64 ;;; specifier will be empty.
65
66 ;;; New variables (user options):
67 ;;; dired-cd-same-subdir
68 ;;; dired-cd-on-each
69 ;;;
70 ;;; Replaces procedures:
71 ;;; dired-do-shell-command (new doc and prompt, calls dired-cd-wrap-it)
72 ;;;
73 ;;; Adds procedures:
74 ;;; dired-cd-wrap-it (wraps calls to dired-shell-stuff-it with "cd <dir>")
75 ;;; dired-files-same-directory
76
77
78 ;; INSTALLATION
79 ;;
80 ;; Put this file into your load-path and add (load "dired-cd") to
81 ;; your dired-load-hook, e.g.
82 ;;
83 ;; (setq dired-load-hook '(lambda ()
84 ;; ;; possibly more statements here
85 ;; (load "dired-cd")))
86 ;;
87 ;; Do (setq dired-cd-same-subdir t) and perhaps (setq dired-cd-on-each t)
88 ;; in your .emacs. By default, dired-cd doesn't change the behavior of
89 ;; dired when it is loaded.
90 ;;
91 ;; If dired-cd-same-subdir is non-nil, then the shell commands cd to
92 ;; the appropriate directory if all the selected files (marked,
93 ;; numeric ARG, etc.) are in that directory; however, on-each behavior
94 ;; is not changed.
95 ;;
96 ;; If dired-cd-on-each is non-nil, then each instance of the command
97 ;; for an on-each shell command runs in the file's directory
98 ;; regardless of whether the files are all in the same directory.
99
100
101 (defvar dired-cd-same-subdir nil
102 "*If non-nil, and selected file(s) (by marks, numeric arg, \\[universal-argument]) are in same
103 subdir, causes dired shell command to run in that subdir. Filenames provided
104 to shell commands are stripped of their directory components. Does not
105 affect behavior of on-each, for that see variable dired-cd-on-each.")
106
107 (defvar dired-cd-on-each nil
108 "*If non-nil, on-each causes each dired shell command to run in the
109 file's directory. Filenames provided to shell commands are stripped of
110 their directory components. Also see variable dired-cd-same-subdir.")
111
112 ;; Redefines dired.el's version.
113 ;; Changes to documentation and prompt, and uses dired-cd-wrap-it.
114 (defun dired-do-shell-command (&optional arg in-background)
115 "Run a shell command on the marked files.
116 If there is output, it goes to a separate buffer.
117 The list of marked files is appended to the command string unless asterisks
118 `*' indicate the place(s) where the list should go.
119 If no files are marked or a specific numeric prefix arg is given, uses
120 next ARG files. With a zero argument, run command on each marked file
121 separately: `cmd * foo' results in `cmd F1 foo; ...; cmd Fn foo'.
122 As always, a raw arg (\\[universal-argument]) means the current file.
123 The option variables dired-cd-same-subdir and dired-cd-on-each
124 permit the command\(s\) to run in the files' directories if appropriate,
125 and thus determine where output files are created. Default is top
126 directory. The prompt mentions the file(s) or the marker, the cd subdir,
127 and the on-each flags when they apply.
128 No automatic redisplay is attempted, as the file names may have
129 changed. Type \\[dired-do-redisplay] to redisplay the marked files."
130 ;; Function dired-shell-stuff-it (called by dired-cd-wrap-it) does the
131 ;; actual file-name substitution and can be redefined for customization.
132 (interactive "P")
133 (let* ((on-each (equal arg 0))
134 (file-list (dired-mark-get-files t (if on-each nil arg)))
135 (prompt (concat (if in-background "& " "! ")
136 (if (or (and on-each dired-cd-on-each)
137 (and dired-cd-same-subdir
138 (not on-each)
139 (dired-files-same-directory file-list)))
140 "cd <dir>; " "")
141 "on "
142 (if on-each "each " "")
143 "%s: "))
144 ;; Give feedback on file(s) and working directory status
145 (command (dired-read-shell-command
146 prompt (if on-each nil arg) file-list))
147 (result (dired-cd-wrap-it command file-list on-each arg)))
148 ;; execute the shell command
149 (dired-run-shell-command result in-background)))
150
151 (defun dired-cd-wrap-it (command files on-each &optional raw)
152 "Args COMMAND FILES ON-EACH &optional RAW-ARG, like dired-shell-stuff-it.
153 Calls dired-shell-stuff-it, but wraps the resulting command\(s\)
154 with \"cd <dir>\" commands when appropriate. Note: when ON-EACH is non-nil,
155 dired-shell-stuff-it is called once for each file in FILES.
156 See documentation of variables dired-cd-same-subdir and dired-cd-on-each
157 for wrap conditions."
158 (if on-each;; command applied to each file separately
159 ;; cd's are done in subshells since all shells I know of have subshells
160 (let* ((cwd "");; current working directory
161 (in-subshell nil)
162 (cmd (mapconcat;; files over command, fuss with "cd <dir>"
163 (function
164 (lambda (file)
165 (let ((cd "") d);; cd command and file's directory
166 (if (not dired-cd-on-each) nil;; poor man's (when ...)
167 (setq d;; directory, relative to default-directory
168 (directory-file-name
169 (or (file-name-directory file) ""))
170 file (file-name-nondirectory file))
171 (if (not (string= d cwd));; new subdir, new subshell
172 (setq cwd d
173 ;; close existing subshell,
174 ;; open a new one
175 cd (concat (if in-subshell "); " "")
176 "(cd " (shell-quote cwd) "; ")
177 in-subshell t))
178 )
179 ;; existing dired-shell-stuff-it does
180 ;; actual command substitution
181 (concat cd (dired-shell-stuff-it command (list file)
182 on-each raw)))))
183 files "; ")))
184 (if in-subshell (concat cmd ")") cmd));; close an open subshell
185
186 ;; not on-each, all files are args to single command instance
187 (let ((same-dir (and dired-cd-same-subdir
188 (dired-files-same-directory files nil)))
189 (cd ""))
190 ;; Let the prepended cd command be relative to default-directory,
191 ;; and only give it if necessary. This way, after ange-ftp
192 ;; prepends its own cd command, it will still work.
193 ;; sk 3-Sep-1991 14:23
194 ;; hsw 31-Oct-1991 -- filenames relative to default-directory
195 (if (and same-dir (not (equal same-dir "")))
196 (setq files (mapcar (function file-name-nondirectory) files)
197 cd (concat "cd " (shell-quote same-dir) "; ")))
198 ;; existing dired-shell-stuff-it does the command substitution
199 (concat cd (dired-shell-stuff-it command files on-each raw)))))
200
201 (defun dired-files-same-directory (file-list &optional absolute)
202 "If all files in LIST are in the same directory return it, otherwise nil.
203 Returned name has no trailing slash. \"Same\" means file-name-directory of
204 the files are string=. File names in LIST must all be absolute or all be
205 relative. Implicitly, relative file names are in default-directory. If
206 optional ABS is non-nil, the returned name will be absolute, otherwise the
207 returned name will be absolute or relative as per the files in LIST."
208 (let ((dir (file-name-directory (car file-list))))
209 (if (memq nil (mapcar (function
210 (lambda (file)
211 (string= dir (file-name-directory file))))
212 file-list))
213 nil
214 (directory-file-name
215 (if (or (not absolute) (and dir (file-name-absolute-p dir)))
216 (or dir "")
217 (concat default-directory dir))))))
218
219 (provide 'dired-cd)