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