lisp/jka-cmpr-hook.el

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