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