[bpt/emacs.git] / lisp / jka-cmpr-hook.el

;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el

;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003,
;;   2004, 2005 Free Software Foundation, Inc.

;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
;; Keywords: data

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This file contains the  code to enable and disable Auto-Compression mode.
;; It is preloaded.  The guts of this mode are in jka-compr.el, which
;; is loaded only when you really try to uncompress something.

;;; Code:

(defgroup compression nil
  "Data compression utilities."
  :group 'data)

(defgroup jka-compr nil
  "jka-compr customization."
  :group 'compression)

;; I have this defined so that .Z files are assumed to be in unix
;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
(defcustom jka-compr-compression-info-list
  ;;[regexp
  ;; compr-message  compr-prog  compr-args
  ;; uncomp-message uncomp-prog uncomp-args
  ;; can-append auto-mode-flag strip-extension-flag file-magic-bytes]
  '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
     "compressing"    "compress"     ("-c")
     "uncompressing"  "uncompress"   ("-c")
     nil t "\037\235"]
     ;; Formerly, these had an additional arg "-c", but that fails with
     ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
     ;; "Version 0.9.0b, 9-Sept-98".
    ["\\.bz2\\'"
     "bzip2ing"        "bzip2"         nil
     "bunzip2ing"      "bzip2"         ("-d")
     nil t "BZh"]
    ["\\.tbz\\'"
     "bzip2ing"        "bzip2"         nil
     "bunzip2ing"      "bzip2"         ("-d")
     nil nil "BZh"]
    ["\\.tgz\\'"
     "compressing"        "gzip"         ("-c" "-q")
     "uncompressing"      "gzip"         ("-c" "-q" "-d")
     t nil "\037\213"]
    ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
     "compressing"        "gzip"         ("-c" "-q")
     "uncompressing"      "gzip"         ("-c" "-q" "-d")
     t t "\037\213"]
    ;; dzip is gzip with random access.  Its compression program can't
    ;; read/write stdin/out, so .dz files can only be viewed without
    ;; saving, having their contents decompressed with gzip.
    ["\\.dz\\'"
     nil              nil            nil
     "uncompressing"      "gzip"         ("-c" "-q" "-d")
     nil t "\037\213"])

  "List of vectors that describe available compression techniques.
Each element, which describes a compression technique, is a vector of
the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:

   regexp                is a regexp that matches filenames that are
                         compressed with this format

   compress-msg          is the message to issue to the user when doing this
                         type of compression (nil means no message)

   compress-program      is a program that performs this compression
                         (nil means visit file in read-only mode)

   compress-args         is a list of args to pass to the compress program

   uncompress-msg        is the message to issue to the user when doing this
                         type of uncompression (nil means no message)

   uncompress-program    is a program that performs this compression

   uncompress-args       is a list of args to pass to the uncompress program

   append-flag           is non-nil if this compression technique can be
                         appended

   strip-extension-flag  non-nil means strip the regexp from file names
                         before attempting to set the mode.

   file-magic-chars      is a string of characters that you would find
			 at the beginning of a file compressed in this way.

Because of the way `call-process' is defined, discarding the stderr output of
a program adds the overhead of starting a shell each time the program is
invoked."
  :type '(repeat (vector regexp
			 (choice :tag "Compress Message"
				 (string :format "%v")
				 (const :tag "No Message" nil))
			 (choice :tag "Compress Program"
				 (string)
				 (const :tag "None" nil))
			 (repeat :tag "Compress Arguments" string)
			 (choice :tag "Uncompress Message"
				 (string :format "%v")
				 (const :tag "No Message" nil))
			 (choice :tag "Uncompress Program"
				 (string)
				 (const :tag "None" nil))
			 (repeat :tag "Uncompress Arguments" string)
			 (boolean :tag "Append")
			 (boolean :tag "Strip Extension")
			 (string :tag "Magic Bytes")))
  :group 'jka-compr)

(defcustom jka-compr-mode-alist-additions
  (list (cons "\\.tgz\\'" 'tar-mode) (cons "\\.tbz\\'" 'tar-mode))
  "A list of pairs to add to `auto-mode-alist' when jka-compr is installed."
  :type '(repeat (cons string symbol))
  :group 'jka-compr)

(defcustom jka-compr-load-suffixes '(".gz")
  "List of suffixes to try when loading files."
  :type '(repeat string)
  :group 'jka-compr)

;; List of all the elements we actually added to file-coding-system-alist.
(defvar jka-compr-added-to-file-coding-system-alist nil)

(defvar jka-compr-file-name-handler-entry
  nil
  "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
\f
(defun jka-compr-build-file-regexp ()
  (mapconcat
   'jka-compr-info-regexp
   jka-compr-compression-info-list
   "\\|"))

;; Functions for accessing the return value of jka-compr-get-compression-info
(defun jka-compr-info-regexp               (info)  (aref info 0))
(defun jka-compr-info-compress-message     (info)  (aref info 1))
(defun jka-compr-info-compress-program     (info)  (aref info 2))
(defun jka-compr-info-compress-args        (info)  (aref info 3))
(defun jka-compr-info-uncompress-message   (info)  (aref info 4))
(defun jka-compr-info-uncompress-program   (info)  (aref info 5))
(defun jka-compr-info-uncompress-args      (info)  (aref info 6))
(defun jka-compr-info-can-append           (info)  (aref info 7))
(defun jka-compr-info-strip-extension      (info)  (aref info 8))
(defun jka-compr-info-file-magic-bytes     (info)  (aref info 9))


(defun jka-compr-get-compression-info (filename)
  "Return information about the compression scheme of FILENAME.
The determination as to which compression scheme, if any, to use is
based on the filename itself and `jka-compr-compression-info-list'."
  (catch 'compression-info
    (let ((case-fold-search nil))
      (mapcar
       (function (lambda (x)
		   (and (string-match (jka-compr-info-regexp x) filename)
			(throw 'compression-info x))))
       jka-compr-compression-info-list)
      nil)))

(defun jka-compr-install ()
  "Install jka-compr.
This adds entries to `file-name-handler-alist' and `auto-mode-alist'
and `inhibit-first-line-modes-suffixes'."

  (setq jka-compr-file-name-handler-entry
	(cons (jka-compr-build-file-regexp) 'jka-compr-handler))

  (push jka-compr-file-name-handler-entry file-name-handler-alist)

  (dolist (x jka-compr-compression-info-list)
    ;; Don't do multibyte encoding on the compressed files.
    (let ((elt (cons (jka-compr-info-regexp x)
                     '(no-conversion . no-conversion))))
      (push elt file-coding-system-alist)
      (push elt jka-compr-added-to-file-coding-system-alist))

    (and (jka-compr-info-strip-extension x)
         ;; Make entries in auto-mode-alist so that modes
         ;; are chosen right according to the file names
         ;; sans `.gz'.
         (push (list (jka-compr-info-regexp x) nil 'jka-compr) auto-mode-alist)
         ;; Also add these regexps to
         ;; inhibit-first-line-modes-suffixes, so that a
         ;; -*- line in the first file of a compressed tar
         ;; file doesn't override tar-mode.
         (push (jka-compr-info-regexp x)
               inhibit-first-line-modes-suffixes)))
  (setq auto-mode-alist
	(append auto-mode-alist jka-compr-mode-alist-additions))

  ;; Make sure that (load "foo") will find /bla/foo.el.gz.
  (setq load-suffixes
	(apply 'append
	       (append (mapcar (lambda (suffix)
                               (cons suffix
                                     (mapcar (lambda (ext) (concat suffix ext))
                                             jka-compr-load-suffixes)))
                             load-suffixes)
                       (list jka-compr-load-suffixes)))))


(defun jka-compr-installed-p ()
  "Return non-nil if jka-compr is installed.
The return value is the entry in `file-name-handler-alist' for jka-compr."

  (let ((fnha file-name-handler-alist)
	(installed nil))

    (while (and fnha (not installed))
     (and (eq (cdr (car fnha)) 'jka-compr-handler)
	   (setq installed (car fnha)))
      (setq fnha (cdr fnha)))

    installed))

(define-minor-mode auto-compression-mode
  "Toggle automatic file compression and uncompression.
With prefix argument ARG, turn auto compression on if positive, else off.
Returns the new status of auto compression (non-nil means on)."
  :global t :init-value t :group 'jka-compr
  (let* ((installed (jka-compr-installed-p))
	 (flag auto-compression-mode))
    (cond
     ((and flag installed) t)		; already installed
     ((and (not flag) (not installed)) nil) ; already not installed
     (flag (jka-compr-install))
     (t (jka-compr-uninstall)))))

(defmacro with-auto-compression-mode (&rest body)
  "Evalute BODY with automatic file compression and uncompression enabled."
  (let ((already-installed (make-symbol "already-installed")))
    `(let ((,already-installed (jka-compr-installed-p)))
       (unwind-protect
	   (progn
	     (unless ,already-installed
	       (jka-compr-install))
	     ,@body)
	 (unless ,already-installed
	   (jka-compr-uninstall))))))
(put 'with-auto-compression-mode 'lisp-indent-function 0)


;; This is what we need to know about jka-compr-handler
;; in order to decide when to call it.

(put 'jka-compr-handler 'safe-magic t)
(put 'jka-compr-handler 'operations '(byte-compiler-base-file-name
				      write-region insert-file-contents
				      file-local-copy load))

;; Turn on the mode.
(when auto-compression-mode (auto-compression-mode 1))

(provide 'jka-cmpr-hook)

;; arch-tag: 4bd73429-f400-45fe-a065-270a113e31a8
;;; jka-cmpr-hook.el ends here
Commit	Line	Data
550bd514	1	;;; jka-cmpr-hook.el --- preloaded code to enable jka-compr.el
216b5993	2
0d30b337 TTN	3	;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003,
0d30b337 TTN	4	;; 2004, 2005 Free Software Foundation, Inc.
216b5993 RS	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
086add15 LK	24	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
086add15 LK	25	;; Boston, MA 02110-1301, USA.
216b5993 RS	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
7ae4587b	36	"Data compression utilities."
216b5993 RS	37	:group 'data)
	38
	39	(defgroup jka-compr nil
7ae4587b	40	"jka-compr customization."
216b5993 RS	41	:group 'compression)
216b5993 RS	42
be93a2c4 SM	43	;; I have this defined so that .Z files are assumed to be in unix
be93a2c4 SM	44	;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
216b5993 RS	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
be93a2c4	161	;; Functions for accessing the return value of jka-compr-get-compression-info
216b5993 RS	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
be93a2c4 SM	195	(push jka-compr-file-name-handler-entry file-name-handler-alist)
	196
	197	(dolist (x jka-compr-compression-info-list)
	198	;; Don't do multibyte encoding on the compressed files.
	199	(let ((elt (cons (jka-compr-info-regexp x)
	200	'(no-conversion . no-conversion))))
	201	(push elt file-coding-system-alist)
	202	(push elt jka-compr-added-to-file-coding-system-alist))
	203
	204	(and (jka-compr-info-strip-extension x)
	205	;; Make entries in auto-mode-alist so that modes
	206	;; are chosen right according to the file names
	207	;; sans `.gz'.
	208	(push (list (jka-compr-info-regexp x) nil 'jka-compr) auto-mode-alist)
	209	;; Also add these regexps to
	210	;; inhibit-first-line-modes-suffixes, so that a
	211	;; -*- line in the first file of a compressed tar
	212	;; file doesn't override tar-mode.
	213	(push (jka-compr-info-regexp x)
	214	inhibit-first-line-modes-suffixes)))
216b5993 RS	215	(setq auto-mode-alist
	216	(append auto-mode-alist jka-compr-mode-alist-additions))
	217
	218	;; Make sure that (load "foo") will find /bla/foo.el.gz.
	219	(setq load-suffixes
	220	(apply 'append
be93a2c4 SM	221	(append (mapcar (lambda (suffix)
	222	(cons suffix
	223	(mapcar (lambda (ext) (concat suffix ext))
	224	jka-compr-load-suffixes)))
	225	load-suffixes)
	226	(list jka-compr-load-suffixes)))))
216b5993 RS	227
	228
	229	(defun jka-compr-installed-p ()
	230	"Return non-nil if jka-compr is installed.
	231	The return value is the entry in `file-name-handler-alist' for jka-compr."
	232
	233	(let ((fnha file-name-handler-alist)
	234	(installed nil))
	235
	236	(while (and fnha (not installed))
	237	(and (eq (cdr (car fnha)) 'jka-compr-handler)
	238	(setq installed (car fnha)))
	239	(setq fnha (cdr fnha)))
	240
	241	installed))
	242
	243	(define-minor-mode auto-compression-mode
	244	"Toggle automatic file compression and uncompression.
	245	With prefix argument ARG, turn auto compression on if positive, else off.
	246	Returns the new status of auto compression (non-nil means on)."
12d94429	247	:global t :init-value t :group 'jka-compr
216b5993 RS	248	(let* ((installed (jka-compr-installed-p))
	249	(flag auto-compression-mode))
	250	(cond
	251	((and flag installed) t) ; already installed
	252	((and (not flag) (not installed)) nil) ; already not installed
	253	(flag (jka-compr-install))
	254	(t (jka-compr-uninstall)))))
	255
	256	(defmacro with-auto-compression-mode (&rest body)
	257	"Evalute BODY with automatic file compression and uncompression enabled."
	258	(let ((already-installed (make-symbol "already-installed")))
	259	`(let ((,already-installed (jka-compr-installed-p)))
	260	(unwind-protect
	261	(progn
	262	(unless ,already-installed
	263	(jka-compr-install))
	264	,@body)
	265	(unless ,already-installed
	266	(jka-compr-uninstall))))))
	267	(put 'with-auto-compression-mode 'lisp-indent-function 0)
	268
	269
be93a2c4 SM	270	;; This is what we need to know about jka-compr-handler
be93a2c4 SM	271	;; in order to decide when to call it.
216b5993 RS	272
216b5993 RS	273	(put 'jka-compr-handler 'safe-magic t)
9c40111a	274	(put 'jka-compr-handler 'operations '(byte-compiler-base-file-name
216b5993 RS	275	write-region insert-file-contents
	276	file-local-copy load))
	277
be93a2c4	278	;; Turn on the mode.
12d94429	279	(when auto-compression-mode (auto-compression-mode 1))
216b5993	280
550bd514	281	(provide 'jka-cmpr-hook)
216b5993	282
b21eabf6	283	;; arch-tag: 4bd73429-f400-45fe-a065-270a113e31a8
550bd514	284	;;; jka-cmpr-hook.el ends here