1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 ;; Description: Commands for compressing marked files.
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;;; Requirements and provisions
17 (defun dired-do-compress (&optional arg files)
18 "Compress or uncompress marked (or next ARG) files.
19 With a zero prefix, prompts for a new value of `dired-compression-method'."
21 (let ((arg (prefix-numeric-value current-prefix-arg))
24 (let ((new (completing-read
25 (format "Set compression method (currently %s): "
26 dired-compression-method)
30 (cons (symbol-name (car x)) nil)))
31 dired-compression-method-alist)
33 (or (string-equal new "")
34 (setq dired-compression-method (intern new))))
35 (setq files (dired-get-marked-files nil current-prefix-arg))
36 (or (memq 'compress dired-no-confirm)
37 (let* ((dir (dired-current-directory))
38 (rfiles (mapcar (function
40 (dired-make-relative fn dir t)))
45 (total (length files))
50 (dired-make-compressed-filename fn)))
51 (let* ((method (car (nth 3 elt)))
52 (count (assoc method uncomp)))
54 (setcdr count (1+ (cdr count)))
55 (setq uncomp (cons (cons method 1) uncomp))))
56 (setq comp (1+ comp)))))
63 (assq dired-compression-method
64 dired-compression-method-alist)))
67 (let ((case-fold-search t)
69 (or (string-equal prompt "")
70 (setq prompt (concat prompt "; ")))
76 (setq method (car elt))
77 (if (string-equal method "gzip")
78 (setq method "gunzip")
79 (or (string-match "^un" method)
80 (setq method (concat "un" method))))
86 (string< (car x) (car y))))))
92 (format "%s %d" (car elt) (cdr elt))))
95 ((= (length rfiles) 1)
96 (setq prompt (format "%s %s? "
97 ;; Don't need the number 1
98 (substring prompt 0 -2)
100 ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp))
101 (setq prompt (format "%s? Total: %d file%s " prompt total
102 (dired-plural-s total))))
103 ((setq prompt (format "%s file%s? " prompt
104 (dired-plural-s total)))))
105 (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
109 (if (not (zerop arg))
112 "Compress or Uncompress"
116 (let ((cfn (dired-make-compressed-filename fn)))
119 (substring fn 0 (- (length (nth 1 cfn))))))))
120 dired-keep-marker-compress nil t)))
123 (defun dired-compress-subdir-files (&optional uncompress)
124 "Compress all uncompressed files in the current subdirectory.
125 With a prefix argument uncompresses all compressed files."
127 (let ((dir (dired-current-directory))
128 files methods uncomp elt)
131 (narrow-to-region (dired-subdir-min) (dired-subdir-max))
132 (dired-map-dired-file-lines
136 (and (listp (setq uncomp (dired-make-compressed-filename f)))
137 (let ((program (car (nth 3 uncomp))))
138 (setq files (cons f files))
139 (if (setq elt (assoc program methods))
140 (setcdr elt (1+ (cdr elt)))
141 (setq methods (cons (cons program 1) methods)))))
142 (and (stringp (dired-make-compressed-filename f))
143 (setq files (cons f files)))))))))
145 (let ((total (length files))
149 (dired-make-relative fn dir t)))
154 (setq prompt (mapconcat
158 (if (string-equal (car x) "gzip")
160 (if (string-match "^un" (car x))
162 (concat "un" (car x))))
168 (concat (substring prompt 0 -1) (car rfiles) "? ")))
169 ((= (length methods) 1)
171 (format "%s file%s? " prompt (dired-plural-s total))))
173 (setq prompt (format "%s? Total: %d file%s " prompt total
174 (dired-plural-s total))))))
177 (format "%s %s? " dired-compression-method (car rfiles))
178 (format "%s %d file%s? "
179 dired-compression-method total
180 (dired-plural-s total)))))
181 (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt)
184 "Compress or Uncompress"
188 (let ((cfn (dired-make-compressed-filename fn)))
191 (substring fn 0 (- (length (nth 1 cfn))))))))
192 dired-keep-marker-compress nil t)))
193 (message "No files need %scompressing in %s."
194 (if uncompress "un" "")
195 (dired-abbreviate-file-name dir)))))
197 (defun dired-compress-file (file ok-flag)
198 ;; Compress or uncompress FILE.
199 ;; If ok-flag is non-nil, it is OK to overwrite an existing
200 ;; file. How well this actually works may depend on the compression
202 ;; Return the name of the compressed or uncompressed file.
203 (let ((handler (find-file-name-handler file 'dired-compress-file)))
205 (funcall handler 'dired-compress-file file ok-flag)
206 (let ((compressed-fn (dired-make-compressed-filename file))
207 (err-buff (get-buffer-create " *dired-check-process output*")))
209 (set-buffer err-buff)
211 (cond ((file-symlink-p file)
212 (signal 'file-error (list "Error compressing file"
213 file "a symbolic link")))
214 ((listp compressed-fn)
215 (message "Uncompressing %s..." file)
216 (let* ((data (nth 3 compressed-fn))
222 (list (nth 4 compressed-fn)))
224 (if (or (and (integerp ret) (/= ret 0))
228 (list "Error uncompressing file"
233 (goto-char (point-min))
235 (point) (progn (end-of-line)
237 (message "Uncompressing %s...done" file)
238 (dired-remove-file file)
239 (let ((to (substring file 0
240 (- (length (nth 1 compressed-fn))))))
241 ;; rename any buffers
242 (and (get-file-buffer file)
244 (set-buffer (get-file-buffer file))
245 (let ((modflag (buffer-modified-p)))
246 ;; kills write-file-hooks
247 (set-visited-file-name to)
248 (set-buffer-modified-p modflag))))
250 ((stringp compressed-fn)
251 (message "Compressing %s..." file)
252 (let* ((data (assq dired-compression-method
253 dired-compression-method-alist))
254 (compr-args (nth 2 data))
257 (car compr-args) nil t nil
258 (append (cdr compr-args)
262 (if (or (and (integerp ret) (/= ret 0))
266 (list "Error compressing file"
271 (goto-char (point-min))
273 (point) (progn (end-of-line)
275 (message "Compressing %s...done" file)
276 (dired-remove-file file)
277 ;; rename any buffers
278 (and (get-file-buffer file)
280 (set-buffer (get-file-buffer file))
281 (let ((modflag (buffer-modified-p)))
282 ;; kills write-file-hooks
283 (set-visited-file-name compressed-fn)
284 (set-buffer-modified-p modflag))))
286 (t (error "Strange error in dired-compress-file."))))))))
288 (defun dired-make-compressed-filename (name &optional method)
289 ;; If NAME is in the syntax of a compressed file (according to
290 ;; dired-compression-method-alist), return the data (a list) from this
291 ;; alist on how to uncompress it. Otherwise, return a string, the
292 ;; compressed form of this file name. This is computed using the optional
293 ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of
294 ;; dired-compression-method is used.
295 (let ((handler (find-file-name-handler
296 name 'dired-make-compressed-filename)))
298 (funcall handler 'dired-make-compressed-filename name method)
299 (let ((alist dired-compression-method-alist)
304 (setq ext-len (length (setq ext (nth 1 (car alist))))))
305 (string-equal ext (substring name (- ext-len))))
306 (setq result (car alist)
308 (setq alist (cdr alist))))
311 (nth 1 (or (assq (or method dired-compression-method)
312 dired-compression-method-alist)
313 (error "Unknown compression method: %s"
314 (or method dired-compression-method))))))
317 ;;; end of dired-cmpr.el