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   (setq filename (file-name-sans-versions filename))
 113   (catch 'compression-info
 114     (let ((case-fold-search nil))
 115       (dolist (x jka-compr-compression-info-list)
 116         (and (string-match (jka-compr-info-regexp x) filename)
 117              (throw 'compression-info x)))
 118       nil)))
 119
 120 (defun jka-compr-install ()
 121   "Install jka-compr.
 122 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 123 and `inhibit-local-variables-suffixes'."
 124
 125   (setq jka-compr-file-name-handler-entry
 126         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 127
 128   (push jka-compr-file-name-handler-entry file-name-handler-alist)
 129
 130   (setq jka-compr-compression-info-list--internal
 131         jka-compr-compression-info-list
 132         jka-compr-mode-alist-additions--internal
 133         jka-compr-mode-alist-additions
 134         jka-compr-load-suffixes--internal
 135         jka-compr-load-suffixes)
 136
 137   (dolist (x jka-compr-compression-info-list)
 138     ;; Don't do multibyte encoding on the compressed files.
 139     (let ((elt (cons (jka-compr-info-regexp x)
 140                      '(no-conversion . no-conversion))))
 141       (push elt file-coding-system-alist)
 142       (push elt jka-compr-added-to-file-coding-system-alist))
 143
 144     (and (jka-compr-info-strip-extension x)
 145          ;; Make entries in auto-mode-alist so that modes
 146          ;; are chosen right according to the file names
 147          ;; sans `.gz'.
 148          (push (list (jka-compr-info-regexp x) nil 'jka-compr) auto-mode-alist)
 149          ;; Also add these regexps to inhibit-local-variables-suffixes,
 150          ;; so that a -*- line in the first file of a compressed tar file,
 151          ;; or a Local Variables section in a member file at the end of
 152          ;; the tar file don't override tar-mode.
 153          (push (jka-compr-info-regexp x)
 154                inhibit-local-variables-suffixes)))
 155   (setq auto-mode-alist
 156         (append auto-mode-alist jka-compr-mode-alist-additions))
 157
 158   ;; Make sure that (load "foo") will find /bla/foo.el.gz.
 159   (setq load-file-rep-suffixes
 160         (append load-file-rep-suffixes jka-compr-load-suffixes nil)))
 161
 162 (defun jka-compr-installed-p ()
 163   "Return non-nil if jka-compr is installed.
 164 The return value is the entry in `file-name-handler-alist' for jka-compr."
 165
 166   (let ((fnha file-name-handler-alist)
 167         (installed nil))
 168
 169     (while (and fnha (not installed))
 170      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 171            (setq installed (car fnha)))
 172       (setq fnha (cdr fnha)))
 173
 174     installed))
 175
 176 (defun jka-compr-update ()
 177   "Update Auto Compression mode for changes in option values.
 178 If you change the options `jka-compr-compression-info-list',
 179 `jka-compr-mode-alist-additions' or `jka-compr-load-suffixes'
 180 outside Custom, while Auto Compression mode is already enabled
 181 \(as it is by default), then you have to call this function
 182 afterward to properly update other variables.  Setting these
 183 options through Custom does this automatically."
 184   (when (jka-compr-installed-p)
 185     (jka-compr-uninstall)
 186     (jka-compr-install)))
 187
 188 (defun jka-compr-set (variable value)
 189   "Internal Custom :set function."
 190   (set-default variable value)
 191   (jka-compr-update))
 192
 193 ;; I have this defined so that .Z files are assumed to be in unix
 194 ;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
 195 (defcustom jka-compr-compression-info-list
 196   ;;[regexp
 197   ;; compr-message  compr-prog  compr-args
 198   ;; uncomp-message uncomp-prog uncomp-args
 199   ;; can-append strip-extension-flag file-magic-bytes]
 200   (mapcar 'purecopy
 201   '(["\\.Z\\'"
 202      "compressing"    "compress"     ("-c")
 203      ;; gzip is more common than uncompress. It can only read, not write.
 204      "uncompressing"  "gzip"   ("-c" "-q" "-d")
 205      nil t "\037\235"]
 206      ;; Formerly, these had an additional arg "-c", but that fails with
 207      ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
 208      ;; "Version 0.9.0b, 9-Sept-98".
 209     ["\\.bz2\\'"
 210      "bzip2ing"        "bzip2"         nil
 211      "bunzip2ing"      "bzip2"         ("-d")
 212      nil t "BZh"]
 213     ["\\.tbz2?\\'"
 214      "bzip2ing"        "bzip2"         nil
 215      "bunzip2ing"      "bzip2"         ("-d")
 216      nil nil "BZh"]
 217     ["\\.\\(?:tgz\\|svgz\\|sifz\\)\\'"
 218      "compressing"        "gzip"         ("-c" "-q")
 219      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 220      t nil "\037\213"]
 221     ["\\.g?z\\'"
 222      "compressing"        "gzip"         ("-c" "-q")
 223      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 224      t t "\037\213"]
 225     ["\\.lz\\'"
 226      "Lzip compressing"   "lzip"         ("-c" "-q")
 227      "Lzip uncompressing" "lzip"         ("-c" "-q" "-d")
 228      t t "LZIP"]
 229     ["\\.lzma\\'"
 230      "LZMA compressing"   "lzma"         ("-c" "-q" "-z")
 231      "LZMA uncompressing" "lzma"         ("-c" "-q" "-d")
 232      t t ""]
 233     ["\\.xz\\'"
 234      "XZ compressing"     "xz"           ("-c" "-q")
 235      "XZ uncompressing"   "xz"           ("-c" "-q" "-d")
 236      t t "\3757zXZ\0"]
 237     ;; dzip is gzip with random access.  Its compression program can't
 238     ;; read/write stdin/out, so .dz files can only be viewed without
 239     ;; saving, having their contents decompressed with gzip.
 240     ["\\.dz\\'"
 241      nil              nil            nil
 242      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 243      nil t "\037\213"]))
 244
 245   "List of vectors that describe available compression techniques.
 246 Each element, which describes a compression technique, is a vector of
 247 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
 248 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
 249 APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
 250
 251    regexp                is a regexp that matches filenames that are
 252                          compressed with this format
 253
 254    compress-msg          is the message to issue to the user when doing this
 255                          type of compression (nil means no message)
 256
 257    compress-program      is a program that performs this compression
 258                          (nil means visit file in read-only mode)
 259
 260    compress-args         is a list of args to pass to the compress program
 261
 262    uncompress-msg        is the message to issue to the user when doing this
 263                          type of uncompression (nil means no message)
 264
 265    uncompress-program    is a program that performs this compression
 266
 267    uncompress-args       is a list of args to pass to the uncompress program
 268
 269    append-flag           is non-nil if this compression technique can be
 270                          appended
 271
 272    strip-extension-flag  non-nil means strip the regexp from file names
 273                          before attempting to set the mode.
 274
 275    file-magic-chars      is a string of characters that you would find
 276                          at the beginning of a file compressed in this way.
 277
 278 If you set this outside Custom while Auto Compression mode is
 279 already enabled \(as it is by default), you have to call
 280 `jka-compr-update' after setting it to properly update other
 281 variables.  Setting this through Custom does that automatically."
 282   :type '(repeat (vector regexp
 283                          (choice :tag "Compress Message"
 284                                  (string :format "%v")
 285                                  (const :tag "No Message" nil))
 286                          (choice :tag "Compress Program"
 287                                  (string)
 288                                  (const :tag "None" nil))
 289                          (repeat :tag "Compress Arguments" string)
 290                          (choice :tag "Uncompress Message"
 291                                  (string :format "%v")
 292                                  (const :tag "No Message" nil))
 293                          (choice :tag "Uncompress Program"
 294                                  (string)
 295                                  (const :tag "None" nil))
 296                          (repeat :tag "Uncompress Arguments" string)
 297                          (boolean :tag "Append")
 298                          (boolean :tag "Strip Extension")
 299                          (string :tag "Magic Bytes")))
 300   :set 'jka-compr-set
 301   :version "24.1"                       ; removed version extension piece
 302   :group 'jka-compr)
 303
 304 (defcustom jka-compr-mode-alist-additions
 305   (list (cons (purecopy "\\.tgz\\'") 'tar-mode) (cons (purecopy "\\.tbz2?\\'") 'tar-mode))
 306   "List of pairs added to `auto-mode-alist' when installing jka-compr.
 307 Uninstalling jka-compr removes all pairs from `auto-mode-alist' that
 308 installing added.
 309
 310 If you set this outside Custom while Auto Compression mode is
 311 already enabled \(as it is by default), you have to call
 312 `jka-compr-update' after setting it to properly update other
 313 variables.  Setting this through Custom does that automatically."
 314   :type '(repeat (cons string symbol))
 315   :set 'jka-compr-set
 316   :group 'jka-compr)
 317
 318 (defcustom jka-compr-load-suffixes (list (purecopy ".gz"))
 319   "List of compression related suffixes to try when loading files.
 320 Enabling Auto Compression mode appends this list to `load-file-rep-suffixes',
 321 which see.  Disabling Auto Compression mode removes all suffixes
 322 from `load-file-rep-suffixes' that enabling added.
 323
 324 If you set this outside Custom while Auto Compression mode is
 325 already enabled \(as it is by default), you have to call
 326 `jka-compr-update' after setting it to properly update other
 327 variables.  Setting this through Custom does that automatically."
 328   :type '(repeat string)
 329   :set 'jka-compr-set
 330   :group 'jka-compr)
 331
 332 (define-minor-mode auto-compression-mode
 333   "Toggle Auto Compression mode.
 334 With a prefix argument ARG, enable Auto Compression mode if ARG
 335 is positive, and disable it otherwise.  If called from Lisp,
 336 enable the mode if ARG is omitted or nil.
 337
 338 Auto Compression mode is a global minor mode.  When enabled,
 339 compressed files are automatically uncompressed for reading, and
 340 compressed when writing."
 341   :global t :init-value t :group 'jka-compr :version "22.1"
 342   (let* ((installed (jka-compr-installed-p))
 343          (flag auto-compression-mode))
 344     (cond
 345      ((and flag installed) t)           ; already installed
 346      ((and (not flag) (not installed)) nil) ; already not installed
 347      (flag (jka-compr-install))
 348      (t (jka-compr-uninstall)))))
 349
 350 (defmacro with-auto-compression-mode (&rest body)
 351   "Evaluate BODY with automatic file compression and uncompression enabled."
 352   (declare (indent 0))
 353   (let ((already-installed (make-symbol "already-installed")))
 354     `(let ((,already-installed (jka-compr-installed-p)))
 355        (unwind-protect
 356            (progn
 357              (unless ,already-installed
 358                (jka-compr-install))
 359              ,@body)
 360          (unless ,already-installed
 361            (jka-compr-uninstall))))))
 362
 363 ;; This is what we need to know about jka-compr-handler
 364 ;; in order to decide when to call it.
 365
 366 (put 'jka-compr-handler 'safe-magic t)
 367 (put 'jka-compr-handler 'operations '(byte-compiler-base-file-name
 368                                       write-region insert-file-contents
 369                                       file-local-copy load))
 370
 371 ;; Turn on the mode.
 372 (when auto-compression-mode (auto-compression-mode 1))
 373
 374 (provide 'jka-cmpr-hook)
 375
 376 ;;; jka-cmpr-hook.el ends here