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