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, 2003, 2004, 2005  Free Software Foundation, Inc.
   4
   5 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
   6 ;; Maintainer: FSF
   7 ;; Keywords: data
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  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 ;;; I have this defined so that .Z files are assumed to be in unix
  43 ;;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
  44 (defcustom jka-compr-compression-info-list
  45   ;;[regexp
  46   ;; compr-message  compr-prog  compr-args
  47   ;; uncomp-message uncomp-prog uncomp-args
  48   ;; can-append auto-mode-flag strip-extension-flag file-magic-bytes]
  49   '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
  50      "compressing"    "compress"     ("-c")
  51      "uncompressing"  "uncompress"   ("-c")
  52      nil t "\037\235"]
  53      ;; Formerly, these had an additional arg "-c", but that fails with
  54      ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
  55      ;; "Version 0.9.0b, 9-Sept-98".
  56     ["\\.bz2\\'"
  57      "bzip2ing"        "bzip2"         nil
  58      "bunzip2ing"      "bzip2"         ("-d")
  59      nil t "BZh"]
  60     ["\\.tbz\\'"
  61      "bzip2ing"        "bzip2"         nil
  62      "bunzip2ing"      "bzip2"         ("-d")
  63      nil nil "BZh"]
  64     ["\\.tgz\\'"
  65      "compressing"        "gzip"         ("-c" "-q")
  66      "uncompressing"      "gzip"         ("-c" "-q" "-d")
  67      t nil "\037\213"]
  68     ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
  69      "compressing"        "gzip"         ("-c" "-q")
  70      "uncompressing"      "gzip"         ("-c" "-q" "-d")
  71      t t "\037\213"]
  72     ;; dzip is gzip with random access.  Its compression program can't
  73     ;; read/write stdin/out, so .dz files can only be viewed without
  74     ;; saving, having their contents decompressed with gzip.
  75     ["\\.dz\\'"
  76      nil              nil            nil
  77      "uncompressing"      "gzip"         ("-c" "-q" "-d")
  78      nil t "\037\213"])
  79
  80   "List of vectors that describe available compression techniques.
  81 Each element, which describes a compression technique, is a vector of
  82 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
  83 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
  84 APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
  85
  86    regexp                is a regexp that matches filenames that are
  87                          compressed with this format
  88
  89    compress-msg          is the message to issue to the user when doing this
  90                          type of compression (nil means no message)
  91
  92    compress-program      is a program that performs this compression
  93                          (nil means visit file in read-only mode)
  94
  95    compress-args         is a list of args to pass to the compress program
  96
  97    uncompress-msg        is the message to issue to the user when doing this
  98                          type of uncompression (nil means no message)
  99
 100    uncompress-program    is a program that performs this compression
 101
 102    uncompress-args       is a list of args to pass to the uncompress program
 103
 104    append-flag           is non-nil if this compression technique can be
 105                          appended
 106
 107    strip-extension-flag  non-nil means strip the regexp from file names
 108                          before attempting to set the mode.
 109
 110    file-magic-chars      is a string of characters that you would find
 111                          at the beginning of a file compressed in this way.
 112
 113 Because of the way `call-process' is defined, discarding the stderr output of
 114 a program adds the overhead of starting a shell each time the program is
 115 invoked."
 116   :type '(repeat (vector regexp
 117                          (choice :tag "Compress Message"
 118                                  (string :format "%v")
 119                                  (const :tag "No Message" nil))
 120                          (choice :tag "Compress Program"
 121                                  (string)
 122                                  (const :tag "None" nil))
 123                          (repeat :tag "Compress Arguments" string)
 124                          (choice :tag "Uncompress Message"
 125                                  (string :format "%v")
 126                                  (const :tag "No Message" nil))
 127                          (choice :tag "Uncompress Program"
 128                                  (string)
 129                                  (const :tag "None" nil))
 130                          (repeat :tag "Uncompress Arguments" string)
 131                          (boolean :tag "Append")
 132                          (boolean :tag "Strip Extension")
 133                          (string :tag "Magic Bytes")))
 134   :group 'jka-compr)
 135
 136 (defcustom jka-compr-mode-alist-additions
 137   (list (cons "\\.tgz\\'" 'tar-mode) (cons "\\.tbz\\'" 'tar-mode))
 138   "A list of pairs to add to `auto-mode-alist' when jka-compr is installed."
 139   :type '(repeat (cons string symbol))
 140   :group 'jka-compr)
 141
 142 (defcustom jka-compr-load-suffixes '(".gz")
 143   "List of suffixes to try when loading files."
 144   :type '(repeat string)
 145   :group 'jka-compr)
 146
 147 ;; List of all the elements we actually added to file-coding-system-alist.
 148 (defvar jka-compr-added-to-file-coding-system-alist nil)
 149
 150 (defvar jka-compr-file-name-handler-entry
 151   nil
 152   "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
 153 \f
 154 (defun jka-compr-build-file-regexp ()
 155   (mapconcat
 156    'jka-compr-info-regexp
 157    jka-compr-compression-info-list
 158    "\\|"))
 159
 160 ;;; Functions for accessing the return value of jka-compr-get-compression-info
 161 (defun jka-compr-info-regexp               (info)  (aref info 0))
 162 (defun jka-compr-info-compress-message     (info)  (aref info 1))
 163 (defun jka-compr-info-compress-program     (info)  (aref info 2))
 164 (defun jka-compr-info-compress-args        (info)  (aref info 3))
 165 (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
 166 (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
 167 (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
 168 (defun jka-compr-info-can-append           (info)  (aref info 7))
 169 (defun jka-compr-info-strip-extension      (info)  (aref info 8))
 170 (defun jka-compr-info-file-magic-bytes     (info)  (aref info 9))
 171
 172
 173 (defun jka-compr-get-compression-info (filename)
 174   "Return information about the compression scheme of FILENAME.
 175 The determination as to which compression scheme, if any, to use is
 176 based on the filename itself and `jka-compr-compression-info-list'."
 177   (catch 'compression-info
 178     (let ((case-fold-search nil))
 179       (mapcar
 180        (function (lambda (x)
 181                    (and (string-match (jka-compr-info-regexp x) filename)
 182                         (throw 'compression-info x))))
 183        jka-compr-compression-info-list)
 184       nil)))
 185
 186 (defun jka-compr-install ()
 187   "Install jka-compr.
 188 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 189 and `inhibit-first-line-modes-suffixes'."
 190
 191   (setq jka-compr-file-name-handler-entry
 192         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 193
 194   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
 195                                       file-name-handler-alist))
 196
 197   (setq jka-compr-added-to-file-coding-system-alist nil)
 198
 199   (mapcar
 200    (function (lambda (x)
 201                ;; Don't do multibyte encoding on the compressed files.
 202                (let ((elt (cons (jka-compr-info-regexp x)
 203                                  '(no-conversion . no-conversion))))
 204                  (setq file-coding-system-alist
 205                        (cons elt file-coding-system-alist))
 206                  (setq jka-compr-added-to-file-coding-system-alist
 207                        (cons elt jka-compr-added-to-file-coding-system-alist)))
 208
 209                (and (jka-compr-info-strip-extension x)
 210                     ;; Make entries in auto-mode-alist so that modes
 211                     ;; are chosen right according to the file names
 212                     ;; sans `.gz'.
 213                     (setq auto-mode-alist
 214                           (cons (list (jka-compr-info-regexp x)
 215                                       nil 'jka-compr)
 216                                 auto-mode-alist))
 217                     ;; Also add these regexps to
 218                     ;; inhibit-first-line-modes-suffixes, so that a
 219                     ;; -*- line in the first file of a compressed tar
 220                     ;; file doesn't override tar-mode.
 221                     (setq inhibit-first-line-modes-suffixes
 222                           (cons (jka-compr-info-regexp x)
 223                                 inhibit-first-line-modes-suffixes)))))
 224    jka-compr-compression-info-list)
 225   (setq auto-mode-alist
 226         (append auto-mode-alist jka-compr-mode-alist-additions))
 227
 228   ;; Make sure that (load "foo") will find /bla/foo.el.gz.
 229   (setq load-suffixes
 230         (apply 'append
 231                (mapcar (lambda (suffix)
 232                          (cons suffix
 233                                (mapcar (lambda (ext) (concat suffix ext))
 234                                        jka-compr-load-suffixes)))
 235                        load-suffixes))))
 236
 237
 238 (defun jka-compr-installed-p ()
 239   "Return non-nil if jka-compr is installed.
 240 The return value is the entry in `file-name-handler-alist' for jka-compr."
 241
 242   (let ((fnha file-name-handler-alist)
 243         (installed nil))
 244
 245     (while (and fnha (not installed))
 246      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 247            (setq installed (car fnha)))
 248       (setq fnha (cdr fnha)))
 249
 250     installed))
 251
 252 (define-minor-mode auto-compression-mode
 253   "Toggle automatic file compression and uncompression.
 254 With prefix argument ARG, turn auto compression on if positive, else off.
 255 Returns the new status of auto compression (non-nil means on)."
 256   :global t :group 'jka-compr
 257   (let* ((installed (jka-compr-installed-p))
 258          (flag auto-compression-mode))
 259     (cond
 260      ((and flag installed) t)           ; already installed
 261      ((and (not flag) (not installed)) nil) ; already not installed
 262      (flag (jka-compr-install))
 263      (t (jka-compr-uninstall)))))
 264
 265 (defmacro with-auto-compression-mode (&rest body)
 266   "Evalute BODY with automatic file compression and uncompression enabled."
 267   (let ((already-installed (make-symbol "already-installed")))
 268     `(let ((,already-installed (jka-compr-installed-p)))
 269        (unwind-protect
 270            (progn
 271              (unless ,already-installed
 272                (jka-compr-install))
 273              ,@body)
 274          (unless ,already-installed
 275            (jka-compr-uninstall))))))
 276 (put 'with-auto-compression-mode 'lisp-indent-function 0)
 277
 278
 279 ;;; This is what we need to know about jka-compr-handler
 280 ;;; in order to decide when to call it.
 281
 282 (put 'jka-compr-handler 'safe-magic t)
 283 (put 'jka-compr-handler 'operations '(jka-compr-byte-compiler-base-file-name
 284                                       write-region insert-file-contents
 285                                       file-local-copy load))
 286
 287 ;;; Turn on the mode.
 288 (auto-compression-mode 1)
 289
 290 (provide 'jka-cmpr-hook)
 291
 292 ;; arch-tag: 4bd73429-f400-45fe-a065-270a113e31a8
 293 ;;; jka-cmpr-hook.el ends here