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 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   (mapconcat
  77    'jka-compr-info-regexp
  78    jka-compr-compression-info-list
  79    "\\|")))
  80
  81 ;; Functions for accessing the return value of jka-compr-get-compression-info
  82 (defun jka-compr-info-regexp               (info)  (aref info 0))
  83 (defun jka-compr-info-compress-message     (info)  (aref info 1))
  84 (defun jka-compr-info-compress-program     (info)  (aref info 2))
  85 (defun jka-compr-info-compress-args        (info)  (aref info 3))
  86 (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
  87 (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
  88 (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
  89 (defun jka-compr-info-can-append           (info)  (aref info 7))
  90 (defun jka-compr-info-strip-extension      (info)  (aref info 8))
  91 (defun jka-compr-info-file-magic-bytes     (info)  (aref info 9))
  92
  93
  94 (defun jka-compr-get-compression-info (filename)
  95   "Return information about the compression scheme of FILENAME.
  96 The determination as to which compression scheme, if any, to use is
  97 based on the filename itself and `jka-compr-compression-info-list'."
  98   (catch 'compression-info
  99     (let ((case-fold-search nil))
 100       (mapc
 101        (function (lambda (x)
 102                    (and (string-match (jka-compr-info-regexp x) filename)
 103                         (throw 'compression-info x))))
 104        jka-compr-compression-info-list)
 105       nil)))
 106
 107 (defun jka-compr-install ()
 108   "Install jka-compr.
 109 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 110 and `inhibit-first-line-modes-suffixes'."
 111
 112   (setq jka-compr-file-name-handler-entry
 113         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 114
 115   (push jka-compr-file-name-handler-entry file-name-handler-alist)
 116
 117   (setq jka-compr-compression-info-list--internal
 118         jka-compr-compression-info-list
 119         jka-compr-mode-alist-additions--internal
 120         jka-compr-mode-alist-additions
 121         jka-compr-load-suffixes--internal
 122         jka-compr-load-suffixes)
 123
 124   (dolist (x jka-compr-compression-info-list)
 125     ;; Don't do multibyte encoding on the compressed files.
 126     (let ((elt (cons (jka-compr-info-regexp x)
 127                      '(no-conversion . no-conversion))))
 128       (push elt file-coding-system-alist)
 129       (push elt jka-compr-added-to-file-coding-system-alist))
 130
 131     (and (jka-compr-info-strip-extension x)
 132          ;; Make entries in auto-mode-alist so that modes
 133          ;; are chosen right according to the file names
 134          ;; sans `.gz'.
 135          (push (list (jka-compr-info-regexp x) nil 'jka-compr) auto-mode-alist)
 136          ;; Also add these regexps to
 137          ;; inhibit-first-line-modes-suffixes, so that a
 138          ;; -*- line in the first file of a compressed tar
 139          ;; file doesn't override tar-mode.
 140          (push (jka-compr-info-regexp x)
 141                inhibit-first-line-modes-suffixes)))
 142   (setq auto-mode-alist
 143         (append auto-mode-alist jka-compr-mode-alist-additions))
 144
 145   ;; Make sure that (load "foo") will find /bla/foo.el.gz.
 146   (setq load-file-rep-suffixes
 147         (append load-file-rep-suffixes jka-compr-load-suffixes nil)))
 148
 149 (defun jka-compr-installed-p ()
 150   "Return non-nil if jka-compr is installed.
 151 The return value is the entry in `file-name-handler-alist' for jka-compr."
 152
 153   (let ((fnha file-name-handler-alist)
 154         (installed nil))
 155
 156     (while (and fnha (not installed))
 157      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 158            (setq installed (car fnha)))
 159       (setq fnha (cdr fnha)))
 160
 161     installed))
 162
 163 (defun jka-compr-update ()
 164   "Update Auto Compression mode for changes in option values.
 165 If you change the options `jka-compr-compression-info-list',
 166 `jka-compr-mode-alist-additions' or `jka-compr-load-suffixes'
 167 outside Custom, while Auto Compression mode is already enabled
 168 \(as it is by default), then you have to call this function
 169 afterward to properly update other variables.  Setting these
 170 options through Custom does this automatically."
 171   (when (jka-compr-installed-p)
 172     (jka-compr-uninstall)
 173     (jka-compr-install)))
 174
 175 (defun jka-compr-set (variable value)
 176   "Internal Custom :set function."
 177   (set-default variable value)
 178   (jka-compr-update))
 179
 180 ;; I have this defined so that .Z files are assumed to be in unix
 181 ;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
 182
 183 ;; FIXME? It seems ugly that one has to add "\\(~\\|\\.~[0-9]+~\\)?" to
 184 ;; all the regexps here, in order to match backup files etc.
 185 ;; It's trivial to modify jka-compr-get-compression-info to match
 186 ;; regexps against file-name-sans-versions, but this regexp is also
 187 ;; used to build a file-name-handler-alist entry.
 188 ;; find-file-name-handler does not use file-name-sans-versions.
 189 ;; Perhaps it should,
 190 ;; http://lists.gnu.org/archive/html/emacs-devel/2008-02/msg00812.html,
 191 ;; but it's used all over the place and there are probably other ramifications.
 192 ;; One could modify jka-compr-build-file-regexp to add the backup regexp,
 193 ;; but jka-compr-compression-info-list is a defcustom to which
 194 ;; anything could be added, so it's easiest to leave things as they are.
 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\\(~\\|\\.~[0-9]+~\\)?\\'"
 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\\(~\\|\\.~[0-9]+~\\)?\\'"
 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\\)\\(~\\|\\.~[0-9]+~\\)?\\'"
 218      "compressing"        "gzip"         ("-c" "-q")
 219      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 220      t nil "\037\213"]
 221     ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
 222      "compressing"        "gzip"         ("-c" "-q")
 223      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 224      t t "\037\213"]
 225     ["\\.xz\\(~\\|\\.~[0-9]+~\\)?\\'"
 226      "XZ compressing"     "xz"           ("-c" "-q")
 227      "XZ uncompressing"   "xz"           ("-c" "-q" "-d")
 228      t t "\3757zXZ\0"]
 229     ;; dzip is gzip with random access.  Its compression program can't
 230     ;; read/write stdin/out, so .dz files can only be viewed without
 231     ;; saving, having their contents decompressed with gzip.
 232     ["\\.dz\\'"
 233      nil              nil            nil
 234      "uncompressing"      "gzip"         ("-c" "-q" "-d")
 235      nil t "\037\213"]))
 236
 237   "List of vectors that describe available compression techniques.
 238 Each element, which describes a compression technique, is a vector of
 239 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
 240 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
 241 APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
 242
 243    regexp                is a regexp that matches filenames that are
 244                          compressed with this format
 245
 246    compress-msg          is the message to issue to the user when doing this
 247                          type of compression (nil means no message)
 248
 249    compress-program      is a program that performs this compression
 250                          (nil means visit file in read-only mode)
 251
 252    compress-args         is a list of args to pass to the compress program
 253
 254    uncompress-msg        is the message to issue to the user when doing this
 255                          type of uncompression (nil means no message)
 256
 257    uncompress-program    is a program that performs this compression
 258
 259    uncompress-args       is a list of args to pass to the uncompress program
 260
 261    append-flag           is non-nil if this compression technique can be
 262                          appended
 263
 264    strip-extension-flag  non-nil means strip the regexp from file names
 265                          before attempting to set the mode.
 266
 267    file-magic-chars      is a string of characters that you would find
 268                          at the beginning of a file compressed in this way.
 269
 270 If you set this outside Custom while Auto Compression mode is
 271 already enabled \(as it is by default), you have to call
 272 `jka-compr-update' after setting it to properly update other
 273 variables.  Setting this through Custom does that automatically."
 274   :type '(repeat (vector regexp
 275                          (choice :tag "Compress Message"
 276                                  (string :format "%v")
 277                                  (const :tag "No Message" nil))
 278                          (choice :tag "Compress Program"
 279                                  (string)
 280                                  (const :tag "None" nil))
 281                          (repeat :tag "Compress Arguments" string)
 282                          (choice :tag "Uncompress Message"
 283                                  (string :format "%v")
 284                                  (const :tag "No Message" nil))
 285                          (choice :tag "Uncompress Program"
 286                                  (string)
 287                                  (const :tag "None" nil))
 288                          (repeat :tag "Uncompress Arguments" string)
 289                          (boolean :tag "Append")
 290                          (boolean :tag "Strip Extension")
 291                          (string :tag "Magic Bytes")))
 292   :set 'jka-compr-set
 293   :group 'jka-compr)
 294
 295 (defcustom jka-compr-mode-alist-additions
 296   (list (cons (purecopy "\\.tgz\\'") 'tar-mode) (cons (purecopy "\\.tbz2?\\'") 'tar-mode))
 297   "List of pairs added to `auto-mode-alist' when installing jka-compr.
 298 Uninstalling jka-compr removes all pairs from `auto-mode-alist' that
 299 installing added.
 300
 301 If you set this outside Custom while Auto Compression mode is
 302 already enabled \(as it is by default), you have to call
 303 `jka-compr-update' after setting it to properly update other
 304 variables.  Setting this through Custom does that automatically."
 305   :type '(repeat (cons string symbol))
 306   :set 'jka-compr-set
 307   :group 'jka-compr)
 308
 309 (defcustom jka-compr-load-suffixes (list (purecopy ".gz"))
 310   "List of compression related suffixes to try when loading files.
 311 Enabling Auto Compression mode appends this list to `load-file-rep-suffixes',
 312 which see.  Disabling Auto Compression mode removes all suffixes
 313 from `load-file-rep-suffixes' that enabling added.
 314
 315 If you set this outside Custom while Auto Compression mode is
 316 already enabled \(as it is by default), you have to call
 317 `jka-compr-update' after setting it to properly update other
 318 variables.  Setting this through Custom does that automatically."
 319   :type '(repeat string)
 320   :set 'jka-compr-set
 321   :group 'jka-compr)
 322
 323 (define-minor-mode auto-compression-mode
 324   "Toggle automatic file compression and uncompression.
 325 With prefix argument ARG, turn auto compression on if positive, else off.
 326 Return the new status of auto compression (non-nil means on)."
 327   :global t :init-value t :group 'jka-compr :version "22.1"
 328   (let* ((installed (jka-compr-installed-p))
 329          (flag auto-compression-mode))
 330     (cond
 331      ((and flag installed) t)           ; already installed
 332      ((and (not flag) (not installed)) nil) ; already not installed
 333      (flag (jka-compr-install))
 334      (t (jka-compr-uninstall)))))
 335
 336 (defmacro with-auto-compression-mode (&rest body)
 337   "Evalute BODY with automatic file compression and uncompression enabled."
 338   (declare (indent 0))
 339   (let ((already-installed (make-symbol "already-installed")))
 340     `(let ((,already-installed (jka-compr-installed-p)))
 341        (unwind-protect
 342            (progn
 343              (unless ,already-installed
 344                (jka-compr-install))
 345              ,@body)
 346          (unless ,already-installed
 347            (jka-compr-uninstall))))))
 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