cgit.sxemacs.org Git - packages/blob - xemacs-packages/dired/dired-cmpr.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; File:          dired-cmpr.el
   4 ;; Dired Version: 7.17
   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 ;;;###autoload
  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'."
  20   (interactive
  21    (let ((arg (prefix-numeric-value current-prefix-arg))
  22          files)
  23      (if (zerop arg)
  24          (let ((new (completing-read
  25                      (format "Set compression method (currently %s): "
  26                              dired-compression-method)
  27                      (mapcar
  28                       (function
  29                        (lambda (x)
  30                          (cons (symbol-name (car x)) nil)))
  31                       dired-compression-method-alist)
  32                      nil t)))
  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
  39                                    (lambda (fn)
  40                                      (dired-make-relative fn dir t)))
  41                                     files))
  42                   (prompt "")
  43                   (comp 0)
  44                   (uncomp nil)
  45                   (total (length files))
  46                   elt)
  47              (mapcar (function
  48                       (lambda (fn)
  49                         (if (listp (setq elt
  50                                          (dired-make-compressed-filename fn)))
  51                             (let* ((method (car (nth 3 elt)))
  52                                    (count (assoc method uncomp)))
  53                               (if count
  54                                   (setcdr count (1+ (cdr count)))
  55                                 (setq uncomp (cons (cons method 1) uncomp))))
  56                           (setq comp (1+ comp)))))
  57                      files)
  58              (if (/= comp 0)
  59                  (setq prompt
  60                        (format "%s %d"
  61                                (car
  62                                 (nth 2
  63                                      (assq dired-compression-method
  64                                            dired-compression-method-alist)))
  65                                comp)))
  66              (if uncomp
  67                  (let ((case-fold-search t)
  68                        method)
  69                    (or (string-equal prompt "")
  70                        (setq prompt (concat prompt "; ")))
  71                    (setq uncomp
  72                          (sort
  73                           (mapcar
  74                            (function
  75                             (lambda (elt)
  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))))
  81                               (setcar elt method)
  82                               elt))
  83                            uncomp)
  84                           (function
  85                            (lambda (x y)
  86                              (string< (car x) (car y))))))
  87                    (setq prompt
  88                          (concat prompt
  89                                  (mapconcat
  90                                   (function
  91                                    (lambda (elt)
  92                                      (format "%s %d" (car elt) (cdr elt))))
  93                                   uncomp ", ")))))
  94              (cond
  95               ((= (length rfiles) 1)
  96                (setq prompt (format "%s %s? "
  97                                     ;; Don't need the number 1
  98                                     (substring prompt 0 -2)
  99                                     (car rfiles))))
 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)
 106                  (setq arg 0)))))
 107      (list arg files)))
 108
 109   (if (not (zerop arg))
 110       (dired-create-files
 111        'dired-compress-file
 112        "Compress or Uncompress"
 113        files
 114        (function
 115         (lambda (fn)
 116           (let ((cfn (dired-make-compressed-filename fn)))
 117             (if (stringp cfn)
 118                 cfn
 119               (substring fn 0 (- (length (nth 1 cfn))))))))
 120        dired-keep-marker-compress nil t)))
 121
 122 ;;;###autoload
 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."
 126   (interactive "P")
 127   (let ((dir (dired-current-directory))
 128         files methods uncomp elt)
 129     (save-excursion
 130       (save-restriction
 131         (narrow-to-region (dired-subdir-min) (dired-subdir-max))
 132         (dired-map-dired-file-lines
 133          (function
 134           (lambda (f)
 135             (if uncompress
 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)))))))))
 144     (if files
 145         (let ((total (length files))
 146               (rfiles (mapcar
 147                        (function
 148                         (lambda (fn)
 149                           (dired-make-relative fn dir t)))
 150                        files))
 151               prompt)
 152           (if uncompress
 153               (progn
 154                 (setq prompt (mapconcat
 155                               (function
 156                                (lambda (x)
 157                                  (format "%s %d"
 158                                          (if (string-equal (car x) "gzip")
 159                                              "gunzip"
 160                                            (if (string-match "^un" (car x))
 161                                                (car x)
 162                                              (concat "un" (car x))))
 163                                          (cdr x))))
 164                               methods ", "))
 165                 (cond
 166                  ((= total 1)
 167                   (setq prompt
 168                         (concat (substring prompt 0 -1) (car rfiles) "? ")))
 169                  ((= (length methods) 1)
 170                   (setq prompt
 171                         (format "%s file%s? " prompt (dired-plural-s total))))
 172                  (t
 173                   (setq prompt (format "%s? Total: %d file%s " prompt total
 174                                        (dired-plural-s total))))))
 175             (setq prompt
 176                   (if (= total 1)
 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)
 182               (dired-create-files
 183                'dired-compress-file
 184                "Compress or Uncompress"
 185                files
 186                (function
 187                 (lambda (fn)
 188                   (let ((cfn (dired-make-compressed-filename fn)))
 189                     (if (stringp cfn)
 190                         cfn
 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)))))
 196
 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
 201   ;; program.
 202   ;; Return the name of the compressed or uncompressed file.
 203   (let ((handler (find-file-name-handler file 'dired-compress-file)))
 204     (if handler
 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*")))
 208         (save-excursion
 209           (set-buffer err-buff)
 210           (erase-buffer)
 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))
 217                         (ret
 218                          (apply 'call-process
 219                                 (car data) nil t nil
 220                                 (append (cdr data)
 221                                         (and ok-flag
 222                                              (list (nth 4 compressed-fn)))
 223                                         (list file)))))
 224                    (if (or (and (integerp ret) (/= ret 0))
 225                            (not (bobp)))
 226                        (signal 'file-error
 227                                (nconc
 228                                 (list "Error uncompressing file"
 229                                       file)
 230                                 (and (not (bobp))
 231                                      (list
 232                                       (progn
 233                                         (goto-char (point-min))
 234                                         (buffer-substring
 235                                          (point) (progn (end-of-line)
 236                                                         (point))))))))))
 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)
 243                         (save-excursion
 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))))
 249                    to))
 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))
 255                         (ret
 256                          (apply 'call-process
 257                                 (car compr-args) nil t nil
 258                                 (append (cdr compr-args)
 259                                         (and ok-flag
 260                                              (list (nth 4 data)))
 261                                         (list file)))))
 262                    (if (or (and (integerp ret) (/= ret 0))
 263                            (not (bobp)))
 264                        (signal 'file-error
 265                                (nconc
 266                                 (list "Error compressing file"
 267                                       file)
 268                                 (and (not (bobp))
 269                                      (list
 270                                       (progn
 271                                         (goto-char (point-min))
 272                                         (buffer-substring
 273                                          (point) (progn (end-of-line)
 274                                                         (point))))))))))
 275                  (message "Compressing %s...done" file)
 276                  (dired-remove-file file)
 277                  ;; rename any buffers
 278                  (and (get-file-buffer file)
 279                       (save-excursion
 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))))
 285                  compressed-fn)
 286                 (t (error "Strange error in dired-compress-file."))))))))
 287
 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)))
 297     (if handler
 298         (funcall handler 'dired-make-compressed-filename name method)
 299       (let ((alist dired-compression-method-alist)
 300             (len (length name))
 301             ext ext-len result)
 302         (while alist
 303           (if (and (> len
 304                       (setq ext-len (length (setq ext (nth 1 (car alist))))))
 305                    (string-equal ext (substring name (- ext-len))))
 306               (setq result (car alist)
 307                     alist nil)
 308             (setq alist (cdr alist))))
 309         (or result
 310             (concat name
 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))))))
 315         ))))
 316
 317 ;;; end of dired-cmpr.el