lisp/jka-cmpr-hook.el

   1 ;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el
   2
   3 ;; Copyright (C) 1993-1995, 1997, 1999-2000, 2002-2012
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
   7 ;; Maintainer: FSF
   8 ;; Keywords: data
   9 ;; Package: emacs
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This file contains the code to enable and disable Auto-Compression mode.
  29 ;; It is preloaded.  The guts of this mode are in jka-compr.el, which
  30 ;; is loaded only when you really try to uncompress something.
  31
  32 ;;; Code:
  33
  34 (defgroup compression nil
  35   "Data compression utilities."
  36   :group 'data)
  37
  38 (defgroup jka-compr nil
  39   "jka-compr customization."
  40   :group 'compression)
  41
  42 (defcustom jka-compr-verbose t
  43   "If non-nil, output messages whenever compressing or uncompressing files."
  44   :version "24.1"
  45   :type 'boolean
  46   :group 'jka-compr)
  47
  48 ;; List of all the elements we actually added to file-coding-system-alist.
  49 (defvar jka-compr-added-to-file-coding-system-alist nil)
  50
  51 (defvar jka-compr-file-name-handler-entry
  52   nil
  53   "`file-name-handler-alist' entry used by jka-compr I/O functions.")
  54
  55 ;; Compiler defvars.  These three variables will be defined later with
  56 ;; `defcustom' when everything used in the :set functions is defined.
  57 (defvar jka-compr-compression-info-list)
  58 (defvar jka-compr-mode-alist-additions)
  59 (defvar jka-compr-load-suffixes)
  60
  61 (defvar jka-compr-compression-info-list--internal nil
  62   "Stored value of `jka-compr-compression-info-list'.
  63 If Auto Compression mode is enabled, this is the value of
  64 `jka-compr-compression-info-list' when `jka-compr-install' was last called.
  65 Otherwise, it is nil.")
  66
  67 (defvar jka-compr-mode-alist-additions--internal nil
  68   "Stored value of `jka-compr-mode-alist-additions'.
  69 If Auto Compression mode is enabled, this is the value of
  70 `jka-compr-mode-alist-additions' when `jka-compr-install' was last called.
  71 Otherwise, it is nil.")
  72
  73 (defvar jka-compr-load-suffixes--internal nil
  74   "Stored value of `jka-compr-load-suffixes'.
  75 If Auto Compression mode is enabled, this is the value of
  76 `jka-compr-load-suffixes' when `jka-compr-install' was last called.
  77 Otherwise, it is nil.")
  78
  79 \f
  80 (defun jka-compr-build-file-regexp ()
  81   (purecopy
  82    (let ((re-anchored '())
  83          (re-free '()))
  84      (dolist (e jka-compr-compression-info-list)
  85        (let ((re (jka-compr-info-regexp e)))
  86          (if (string-match "\\\\'\\'" re)
  87              (push (substring re 0 (match-beginning 0)) re-anchored)
  88            (push re re-free))))
  89      (concat
  90       (if re-free (concat (mapconcat 'identity re-free "\\|") "\\|"))
  91       "\\(?:"
  92       (mapconcat 'identity re-anchored "\\|")
  93       "\\)" file-name-version-regexp "?\\'"))))
  94
  95 ;; Functions for accessing the return value of jka-compr-get-compression-info
  96 (defun jka-compr-info-regexp               (info)  (aref info 0))
  97 (defun jka-compr-info-compress-message     (info)  (aref info 1))
  98 (defun jka-compr-info-compress-program     (info)  (aref info 2))
  99 (defun jka-compr-info-compress-args        (info)  (aref info 3))
 100 (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
 101 (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
 102 (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
 103 (defun jka-compr-info-can-append           (info)  (aref info 7))
 104 (defun jka-compr-info-strip-extension      (info)  (aref info 8))
 105 (defun jka-compr-info-file-magic-bytes     (info)  (aref info 9))
 106
 107
 108 (defun jka-compr-get-compression-info (filename)
 109   "Return information about the compression scheme of FILENAME.
 110 The determination as to which compression scheme, if any, to use is
 111 based on the filename itself and `jka-compr-compression-info-list'."
 112   (catch 'compression-info
 113     (let ((case-fold-search nil))
 114       (dolist (x jka-compr-compression-info-list)
 115         (and (string-match (jka-compr-info-regexp x) filename)
 116              (throw 'compression-info x)))
 117       nil)))
 118
 119 (defun jka-compr-install ()
 120   "Install jka-compr.
 121 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 122 and `inhibit-local-variables-suffixes'."
 123
 124   (setq jka-compr-file-name-handler-entry
 125         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 126
 127   (push jka-compr-file-name-handler-entry file-name-handler-alist)
 128
 129   (setq jka-compr-compression-info-list--internal
 130         jka-compr-compression-info-list
 131         jka-compr-mode-alist-additions--internal
 132         jka-compr-mode-alist-additions
 133         jka-compr-load-suffixes--internal
 134         jka-compr-load-suffixes)
 135
 136   (dolist (x jka-compr-compression-info-list)
 137     ;; Don't do multibyte encoding on the compressed files.
 138     (let ((elt (cons (jka-compr-info-regexp x)
 139                      '(no-conversion . no-conversion))))
 140       (push elt file-coding-system-alist)
 141       (push elt jka-compr-added-to-file-coding-system-alist))
 142
 143     (and (jka-compr-info-strip-extension x)
 144          ;; Make entries in auto-mode-alist so that modes
 145          ;; are chosen right according to the file names
 146          ;; sans `.gz'.
 147          (push (list (jka-compr-info-regexp x) nil 'jka-compr) auto-mode-alist)
 148          ;; Also add these regexps to inhibit-local-variables-suffixes,
 149          ;; so that a -*- line in the first file of a compressed tar file,
 150          ;; or a Local Variables section in a member file at the end of
 151          ;; the tar file don't override tar-mode.
 152          (push (jka-compr-info-regexp x)
 153                inhibit-local-variables-suffixes)))
 154   (setq auto-mode-alist
 155         (append auto-mode-alist jka-compr-mode-alist-additions))
 156
 157   ;; Make sure that (load "foo") will find /bla/foo.el.gz.
 158   (setq load-file-rep-suffixes
 159         (append load-file-rep-suffixes jka-compr-load-suffixes nil)))
 160
 161 (defun jka-compr-installed-p ()
 162   "Return non-nil if jka-compr is installed.
 163 The return value is the entry in `file-name-handler-alist' for jka-compr."
 164
 165   (let ((fnha file-name-handler-alist)
 166         (installed nil))
 167
 168     (while (and fnha (not installed))
 169      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 170            (setq installed (car fnha)))
 171       (setq fnha (cdr fnha)))
 172
 173     installed))
 174
 175 (defun jka-compr-update ()
 176   "Update Auto Compression mode for changes in option values.
 177 If you change the options `jka-compr-compression-info-list',
 178 `jka-compr-mode-alist-additions' or `jka-compr-load-suffixes'
 179 outside Custom, while Auto Compression mode is already enabled
 180 \(as it is by default), then you have to call this function
 181 afterward to properly update other variables.  Setting these
 182 options through Custom does this automatically."
 183   (when (jka-compr-installed-p)
 184     (jka-compr-uninstall)
 185     (jka-compr-install)))
 186
 187 (defun jka-compr-set (variable value)
 188   "Internal Custom :set function."
 189   (set-default variable value)
 190   (jka-compr-update))
 191
 192 ;; I have this defined so that .Z files are assumed to be in unix
 193 ;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
 194
 195 ;; FIXME? It seems ugly that one has to add "\\(~\\|\\.~[0-9]+~\\)?" to
 196 ;; all the regexps here, in order to match backup files etc.
 197 ;; It's trivial to modify jka-compr-get-compression-info to match
 198 ;; regexps against file-name-sans-versions, but this regexp is also
 199 ;; used to build a file-name-handler-alist entry.
 200 ;; find-file-name-handler does not use file-name-sans-versions.
 201 ;; Perhaps it should,
 202 ;; http://lists.gnu.org/archive/html/emacs-devel/2008-02/msg00812.html,
 203 ;; but it's used all over the place and there are probably other ramifications.
 204 ;; One could modify jka-compr-build-file-regexp to add the backup regexp,
 205 ;; but jka-compr-compression-info-list is a defcustom to which
 206 ;; anything could be added, so it's easiest to leave things as they are.
 207 (defcustom jka-compr-compression-info-list
 208   ;;[regexp
 209   ;; compr-message  compr-prog  compr-args
 210   ;; uncomp-message uncomp-prog uncomp-args
 211   ;; can-append strip-extension-flag file-magic-bytes]
 212   (mapcar 'purecopy
 213   '(["\\.Z\\'"
 214      "compressing"    "compress"     ("-c")
 215      ;; gzip is more common than uncompress. It can only read, not write.
 216      "uncompressing"  "gzip"   ("-c" "-q" "-d")
 217      nil t "\037\235"]
 218      ;; Formerly, these had an additional arg "-c", but that fails with
 219      ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
 220      ;; "Version 0.9.0b, 9-Sept-98".
 221     ["\\.bz2\\'"
 222      "bzip2ing"        "bzip2"         nil
 223      "bunzip2ing"      "bzip2"         ("-d")
 224      nil t "BZh"]
 225     ["\\.tbz2?\\'"
 226      "bzip2ing"        "bzip2"         nil
 227      "bunzip2ing"      "bzip2"         ("-d")
 228      nil nil "BZh"]
 229     ["\\.\\(?:tgz\\|svgz\\|sifz\\)\\'"
 230      "compressing"        "gzip"         ("-c" "-q")
 231      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 232      t nil "\037\213"]
 233     ["\\.g?z\\'"
 234      "compressing"        "gzip"         ("-c" "-q")
 235      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 236      t t "\037\213"]
 237     ["\\.lz\\'"
 238      "Lzip compressing"   "lzip"         ("-c" "-q")
 239      "Lzip uncompressing" "lzip"         ("-c" "-q" "-d")
 240      t t "LZIP"]
 241     ["\\.lzma\\'"
 242      "LZMA compressing"   "lzma"         ("-c" "-q" "-z")
 243      "LZMA uncompressing" "lzma"         ("-c" "-q" "-d")
 244      t t ""]
 245     ["\\.xz\\'"
 246      "XZ compressing"     "xz"           ("-c" "-q")
 247      "XZ uncompressing"   "xz"           ("-c" "-q" "-d")
 248      t t "\3757zXZ\0"]
 249     ;; dzip is gzip with random access.  Its compression program can't
 250     ;; read/write stdin/out, so .dz files can only be viewed without
 251     ;; saving, having their contents decompressed with gzip.
 252     ["\\.dz\\'"
 253      nil              nil            nil
 254      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 255      nil t "\037\213"]))
 256
 257   "List of vectors that describe available compression techniques.
 258 Each element, which describes a compression technique, is a vector of
 259 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
 260 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
 261 APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
 262
 263    regexp                is a regexp that matches filenames that are
 264                          compressed with this format
 265
 266    compress-msg          is the message to issue to the user when doing this
 267                          type of compression (nil means no message)
 268
 269    compress-program      is a program that performs this compression
 270                          (nil means visit file in read-only mode)
 271
 272    compress-args         is a list of args to pass to the compress program
 273
 274    uncompress-msg        is the message to issue to the user when doing this
 275                          type of uncompression (nil means no message)
 276
 277    uncompress-program    is a program that performs this compression
 278
 279    uncompress-args       is a list of args to pass to the uncompress program
 280
 281    append-flag           is non-nil if this compression technique can be
 282                          appended
 283
 284    strip-extension-flag  non-nil means strip the regexp from file names
 285                          before attempting to set the mode.
 286
 287    file-magic-chars      is a string of characters that you would find
 288                          at the beginning of a file compressed in this way.
 289
 290 If you set this outside Custom while Auto Compression mode is
 291 already enabled \(as it is by default), you have to call
 292 `jka-compr-update' after setting it to properly update other
 293 variables.  Setting this through Custom does that automatically."
 294   :type '(repeat (vector regexp
 295                          (choice :tag "Compress Message"
 296                                  (string :format "%v")
 297                                  (const :tag "No Message" nil))
 298                          (choice :tag "Compress Program"
 299                                  (string)
 300                                  (const :tag "None" nil))
 301                          (repeat :tag "Compress Arguments" string)
 302                          (choice :tag "Uncompress Message"
 303                                  (string :format "%v")
 304                                  (const :tag "No Message" nil))
 305                          (choice :tag "Uncompress Program"
 306                                  (string)
 307                                  (const :tag "None" nil))
 308                          (repeat :tag "Uncompress Arguments" string)
 309                          (boolean :tag "Append")
 310                          (boolean :tag "Strip Extension")
 311                          (string :tag "Magic Bytes")))
 312   :set 'jka-compr-set
 313   :group 'jka-compr)
 314
 315 (defcustom jka-compr-mode-alist-additions
 316   (list (cons (purecopy "\\.tgz\\'") 'tar-mode) (cons (purecopy "\\.tbz2?\\'") 'tar-mode))
 317   "List of pairs added to `auto-mode-alist' when installing jka-compr.
 318 Uninstalling jka-compr removes all pairs from `auto-mode-alist' that
 319 installing added.
 320
 321 If you set this outside Custom while Auto Compression mode is
 322 already enabled \(as it is by default), you have to call
 323 `jka-compr-update' after setting it to properly update other
 324 variables.  Setting this through Custom does that automatically."
 325   :type '(repeat (cons string symbol))
 326   :set 'jka-compr-set
 327   :group 'jka-compr)
 328
 329 (defcustom jka-compr-load-suffixes (list (purecopy ".gz"))
 330   "List of compression related suffixes to try when loading files.
 331 Enabling Auto Compression mode appends this list to `load-file-rep-suffixes',
 332 which see.  Disabling Auto Compression mode removes all suffixes
 333 from `load-file-rep-suffixes' that enabling added.
 334
 335 If you set this outside Custom while Auto Compression mode is
 336 already enabled \(as it is by default), you have to call
 337 `jka-compr-update' after setting it to properly update other
 338 variables.  Setting this through Custom does that automatically."
 339   :type '(repeat string)
 340   :set 'jka-compr-set
 341   :group 'jka-compr)
 342
 343 (define-minor-mode auto-compression-mode
 344   "Toggle Auto Compression mode.
 345 With a prefix argument ARG, enable Auto Compression mode if ARG
 346 is positive, and disable it otherwise.  If called from Lisp,
 347 enable the mode if ARG is omitted or nil.
 348
 349 Auto Compression mode is a global minor mode.  When enabled,
 350 compressed files are automatically uncompressed for reading, and
 351 compressed when writing."
 352   :global t :init-value t :group 'jka-compr :version "22.1"
 353   (let* ((installed (jka-compr-installed-p))
 354          (flag auto-compression-mode))
 355     (cond
 356      ((and flag installed) t)           ; already installed
 357      ((and (not flag) (not installed)) nil) ; already not installed
 358      (flag (jka-compr-install))
 359      (t (jka-compr-uninstall)))))
 360
 361 (defmacro with-auto-compression-mode (&rest body)
 362   "Evaluate BODY with automatic file compression and uncompression enabled."
 363   (declare (indent 0))
 364   (let ((already-installed (make-symbol "already-installed")))
 365     `(let ((,already-installed (jka-compr-installed-p)))
 366        (unwind-protect
 367            (progn
 368              (unless ,already-installed
 369                (jka-compr-install))
 370              ,@body)
 371          (unless ,already-installed
 372            (jka-compr-uninstall))))))
 373
 374 ;; This is what we need to know about jka-compr-handler
 375 ;; in order to decide when to call it.
 376
 377 (put 'jka-compr-handler 'safe-magic t)
 378 (put 'jka-compr-handler 'operations '(byte-compiler-base-file-name
 379                                       write-region insert-file-contents
 380                                       file-local-copy load))
 381
 382 ;; Turn on the mode.
 383 (when auto-compression-mode (auto-compression-mode 1))
 384
 385 (provide 'jka-cmpr-hook)
 386
 387 ;;; jka-cmpr-hook.el ends here