Mercurial > hg > xemacs-beta

comparison lisp/efs/dired-cmpr.el @ 22:8fc7fe29b841 r19-15b94

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b94
author cvs
date Mon, 13 Aug 2007 08:50:29 +0200
parents
children 7e54bd776075 9f59509498e1
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;;
3 ;; File: dired-cmpr.el
4 ;; Dired Version: $Revision: 1.1 $
5 ;; RCS:
6 ;; Description: Commands for compressing marked files.
7 ;;
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9
10 ;;; Requirements and provisions
11 (provide 'dired-cmpr)
12 (require 'dired)
13
14 ;;; Entry points.
15
16 (defun dired-do-compress (&optional arg files)
17 "Compress or uncompress marked (or next ARG) files.
18 With a zero prefix, prompts for a new value of `dired-compression-method'."
19 (interactive
20 (let ((arg (prefix-numeric-value current-prefix-arg))
21 files)
22 (if (zerop arg)
23 (let ((new (completing-read
24 (format "Set compression method (currently %s): "
25 dired-compression-method)
26 (mapcar
27 (function
28 (lambda (x)
29 (cons (symbol-name (car x)) nil)))
30 dired-compression-method-alist)
31 nil t)))
32 (or (string-equal new "")
33 (setq dired-compression-method (intern new))))
34 (setq files (dired-get-marked-files nil current-prefix-arg))
35 (or (memq 'compress dired-no-confirm)
36 (let* ((dir (dired-current-directory))
37 (rfiles (mapcar (function
38 (lambda (fn)
39 (dired-make-relative fn dir t)))
40 files))
41 (prompt "")
42 (comp 0)
43 (uncomp nil)
44 (total (length files))
45 elt)
46 (mapcar (function
47 (lambda (fn)
48 (if (listp (setq elt
49 (dired-make-compressed-filename fn)))
50 (let* ((method (car (nth 3 elt)))
51 (count (assoc method uncomp)))
52 (if count
53 (setcdr count (1+ (cdr count)))
54 (setq uncomp (cons (cons method 1) uncomp))))
55 (setq comp (1+ comp)))))
56 files)
57 (if (/= comp 0)
58 (setq prompt
59 (format "%s %d"
60 (car
61 (nth 2
62 (assq dired-compression-method
63 dired-compression-method-alist)))
64 comp)))
65 (if uncomp
66 (let ((case-fold-search t)
67 method)
68 (or (string-equal prompt "")
69 (setq prompt (concat prompt "; ")))
70 (setq uncomp
71 (sort
72 (mapcar
73 (function
74 (lambda (elt)
75 (setq method (car elt))
76 (if (string-equal method "gzip")
77 (setq method "gunzip")
78 (or (string-match "^un" method)
79 (setq method (concat "un" method))))
80 (setcar elt method)
81 elt))
82 uncomp)
83 (function
84 (lambda (x y)
85 (string< (car x) (car y))))))
86 (setq prompt
87 (concat prompt
88 (mapconcat
89 (function
90 (lambda (elt)
91 (format "%s %d" (car elt) (cdr elt))))
92 uncomp ", ")))))
93 (cond
94 ((= (length rfiles) 1)
95 (setq prompt (format "%s %s? "
96 ;; Don't need the number 1
97 (substring prompt 0 -2)
98 (car rfiles))))
99 ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp))
100 (setq prompt (format "%s? Total: %d file%s " prompt total
101 (dired-plural-s total))))
102 ((setq prompt (format "%s file%s? " prompt
103 (dired-plural-s total)))))
104 (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
105 (setq arg 0)))))
106 (list arg files)))
107
108 (if (not (zerop arg))
109 (dired-create-files
110 'dired-compress-file
111 "Compress or Uncompress"
112 files
113 (function
114 (lambda (fn)
115 (let ((cfn (dired-make-compressed-filename fn)))
116 (if (stringp cfn)
117 cfn
118 (substring fn 0 (- (length (nth 1 cfn))))))))
119 dired-keep-marker-compress nil t)))
120
121 (defun dired-compress-subdir-files (&optional uncompress)
122 "Compress all uncompressed files in the current subdirectory.
123 With a prefix argument uncompresses all compressed files."
124 (interactive "P")
125 (let ((dir (dired-current-directory))
126 files methods uncomp elt)
127 (save-excursion
128 (save-restriction
129 (narrow-to-region (dired-subdir-min) (dired-subdir-max))
130 (dired-map-dired-file-lines
131 (function
132 (lambda (f)
133 (if uncompress
134 (and (listp (setq uncomp (dired-make-compressed-filename f)))
135 (let ((program (car (nth 3 uncomp))))
136 (setq files (cons f files))
137 (if (setq elt (assoc program methods))
138 (setcdr elt (1+ (cdr elt)))
139 (setq methods (cons (cons program 1) methods)))))
140 (and (stringp (dired-make-compressed-filename f))
141 (setq files (cons f files)))))))))
142 (if files
143 (let ((total (length files))
144 (rfiles (mapcar
145 (function
146 (lambda (fn)
147 (dired-make-relative fn dir t)))
148 files))
149 prompt)
150 (if uncompress
151 (progn
152 (setq prompt (mapconcat
153 (function
154 (lambda (x)
155 (format "%s %d"
156 (if (string-equal (car x) "gzip")
157 "gunzip"
158 (if (string-match "^un" (car x))
159 (car x)
160 (concat "un" (car x))))
161 (cdr x))))
162 methods ", "))
163 (cond
164 ((= total 1)
165 (setq prompt
166 (concat (substring prompt 0 -1) (car rfiles) "? ")))
167 ((= (length methods) 1)
168 (setq prompt
169 (format "%s file%s? " prompt (dired-plural-s total))))
170 (t
171 (setq prompt (format "%s? Total: %d file%s " prompt total
172 (dired-plural-s total))))))
173 (setq prompt
174 (if (= total 1)
175 (format "%s %s? " dired-compression-method (car rfiles))
176 (format "%s %d file%s? "
177 dired-compression-method total
178 (dired-plural-s total)))))
179 (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
180 (dired-create-files
181 'dired-compress-file
182 "Compress or Uncompress"
183 files
184 (function
185 (lambda (fn)
186 (let ((cfn (dired-make-compressed-filename fn)))
187 (if (stringp cfn)
188 cfn
189 (substring fn 0 (- (length (nth 1 cfn))))))))
190 dired-keep-marker-compress nil t)))
191 (message "No files need %scompressing in %s."
192 (if uncompress "un" "")
193 (dired-abbreviate-file-name dir)))))
194
195 (defun dired-compress-file (file ok-flag)
196 ;; Compress or uncompress FILE.
197 ;; If ok-flag is non-nil, it is OK to overwrite an existing
198 ;; file. How well this actually works may depend on the compression
199 ;; program.
200 ;; Return the name of the compressed or uncompressed file.
201 (let ((handler (find-file-name-handler file 'dired-compress-file)))
202 (if handler
203 (funcall handler 'dired-compress-file file ok-flag)
204 (let ((compressed-fn (dired-make-compressed-filename file))
205 (err-buff (get-buffer-create " *dired-check-process output*")))
206 (save-excursion
207 (set-buffer err-buff)
208 (erase-buffer)
209 (cond ((file-symlink-p file)
210 (signal 'file-error (list "Error compressing file"
211 file "a symbolic link")))
212 ((listp compressed-fn)
213 (message "Uncompressing %s..." file)
214 (let* ((data (nth 3 compressed-fn))
215 (ret
216 (apply 'call-process
217 (car data) file t nil
218 (append (cdr data)
219 (and ok-flag
220 (list (nth 4 compressed-fn)))
221 (list file)))))
222 (if (or (and (integerp ret) (/= ret 0))
223 (not (bobp)))
224 (signal 'file-error
225 (nconc
226 (list "Error uncompressing file"
227 file)
228 (and (not (bobp))
229 (list
230 (progn
231 (goto-char (point-min))
232 (buffer-substring
233 (point) (progn (end-of-line)
234 (point))))))))))
235 (message "Uncompressing %s...done" file)
236 (dired-remove-file file)
237 (let ((to (substring file 0
238 (- (length (nth 1 compressed-fn))))))
239 ;; rename any buffers
240 (and (get-file-buffer file)
241 (save-excursion
242 (set-buffer (get-file-buffer file))
243 (let ((modflag (buffer-modified-p)))
244 ;; kills write-file-hooks
245 (set-visited-file-name to)
246 (set-buffer-modified-p modflag))))
247 to))
248 ((stringp compressed-fn)
249 (message "Compressing %s..." file)
250 (let* ((data (assq dired-compression-method
251 dired-compression-method-alist))
252 (compr-args (nth 2 data))
253 (ret
254 (apply 'call-process
255 (car compr-args) file t nil
256 (append (cdr compr-args)
257 (and ok-flag
258 (list (nth 4 data)))
259 (list file)))))
260 (if (or (and (integerp ret) (/= ret 0))
261 (not (bobp)))
262 (signal 'file-error
263 (nconc
264 (list "Error compressing file"
265 file)
266 (and (not (bobp))
267 (list
268 (progn
269 (goto-char (point-min))
270 (buffer-substring
271 (point) (progn (end-of-line)
272 (point))))))))))
273 (message "Compressing %s...done" file)
274 (dired-remove-file file)
275 ;; rename any buffers
276 (and (get-file-buffer file)
277 (save-excursion
278 (set-buffer (get-file-buffer file))
279 (let ((modflag (buffer-modified-p)))
280 ;; kills write-file-hooks
281 (set-visited-file-name compressed-fn)
282 (set-buffer-modified-p modflag))))
283 compressed-fn)
284 (t (error "Strange error in dired-compress-file."))))))))
285
286 (defun dired-make-compressed-filename (name &optional method)
287 ;; If NAME is in the syntax of a compressed file (according to
288 ;; dired-compression-method-alist), return the data (a list) from this
289 ;; alist on how to uncompress it. Otherwise, return a string, the
290 ;; compressed form of this file name. This is computed using the optional
291 ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of
292 ;; dired-compression-method is used.
293 (let ((handler (find-file-name-handler
294 name 'dired-make-compressed-filename)))
295 (if handler
296 (funcall handler 'dired-make-compressed-filename name method)
297 (let ((alist dired-compression-method-alist)
298 (len (length name))
299 ext ext-len result)
300 (while alist
301 (if (and (> len
302 (setq ext-len (length (setq ext (nth 1 (car alist))))))
303 (string-equal ext (substring name (- ext-len))))
304 (setq result (car alist)
305 alist nil)
306 (setq alist (cdr alist))))
307 (or result
308 (concat name
309 (nth 1 (or (assq (or method dired-compression-method)
310 dired-compression-method-alist)
311 (error "Unknown compression method: %s"
312 (or method dired-compression-method))))))
313 ))))
314
315 ;;; end of dired-cmpr.el