/[emacs]/emacs/lisp/jka-compr.el
ViewVC logotype

Diff of /emacs/lisp/jka-compr.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.82 by rms, Sun Apr 17 16:00:48 2005 UTC revision 1.83 by rms, Sat Apr 30 20:18:10 2005 UTC
# Line 100  Line 100 
100    
101  ;;; Code:  ;;; Code:
102    
 (defgroup compression nil  
   "Data compression utilities"  
   :group 'data)  
   
 (defgroup jka-compr nil  
   "jka-compr customization"  
   :group 'compression)  
   
   
103  (defcustom jka-compr-shell "sh"  (defcustom jka-compr-shell "sh"
104    "*Shell to be used for calling compression programs.    "*Shell to be used for calling compression programs.
105  The value of this variable only matters if you want to discard the  The value of this variable only matters if you want to discard the
# Line 120  for `jka-compr-compression-info-list')." Line 111  for `jka-compr-compression-info-list')."
111  (defvar jka-compr-use-shell  (defvar jka-compr-use-shell
112    (not (memq system-type '(ms-dos windows-nt))))    (not (memq system-type '(ms-dos windows-nt))))
113    
 ;;; 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\\'"  
      "zipping"        "gzip"         ("-c" "-q")  
      "unzipping"      "gzip"         ("-c" "-q" "-d")  
      t nil "\037\213"]  
     ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"  
      "zipping"        "gzip"         ("-c" "-q")  
      "unzipping"      "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  
      "unzipping"      "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.")  
   
114  (defvar jka-compr-really-do-compress nil  (defvar jka-compr-really-do-compress nil
115    "Non-nil in a buffer whose visited file was uncompressed on visiting it.    "Non-nil in a buffer whose visited file was uncompressed on visiting it.
116  This means compress the data on writing the file, even if the  This means compress the data on writing the file, even if the
# Line 764  There should be no more than seven chara Line 643  There should be no more than seven chara
643  (put 'byte-compiler-base-file-name 'jka-compr  (put 'byte-compiler-base-file-name 'jka-compr
644       'jka-compr-byte-compiler-base-file-name)       'jka-compr-byte-compiler-base-file-name)
645    
646    ;;;###autoload
647  (defvar jka-compr-inhibit nil  (defvar jka-compr-inhibit nil
648    "Non-nil means inhibit automatic uncompression temporarily.    "Non-nil means inhibit automatic uncompression temporarily.
649  Lisp programs can bind this to t to do that.  Lisp programs can bind this to t to do that.
650  It is not recommended to set this variable permanently to anything but nil.")  It is not recommended to set this variable permanently to anything but nil.")
651    
652  (put 'jka-compr-handler 'safe-magic t)  ;;;###autoload
653  (defun jka-compr-handler (operation &rest args)  (defun jka-compr-handler (operation &rest args)
654    (save-match-data    (save-match-data
655      (let ((jka-op (get operation 'jka-compr)))      (let ((jka-op (get operation 'jka-compr)))
# Line 790  It is not recommended to set this variab Line 670  It is not recommended to set this variab
670      (apply operation args)))      (apply operation args)))
671    
672    
 (defun jka-compr-build-file-regexp ()  
   (mapconcat  
    'jka-compr-info-regexp  
    jka-compr-compression-info-list  
    "\\|"))  
   
   
 (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))  
   
   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry  
                                       file-name-handler-alist))  
   
   (setq jka-compr-added-to-file-coding-system-alist nil)  
   
   (mapcar  
    (function (lambda (x)  
                ;; Don't do multibyte encoding on the compressed files.  
                (let ((elt (cons (jka-compr-info-regexp x)  
                                  '(no-conversion . no-conversion))))  
                  (setq file-coding-system-alist  
                        (cons elt file-coding-system-alist))  
                  (setq jka-compr-added-to-file-coding-system-alist  
                        (cons 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'.  
                     (setq auto-mode-alist  
                           (cons (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.  
                     (setq inhibit-first-line-modes-suffixes  
                           (cons (jka-compr-info-regexp x)  
                                 inhibit-first-line-modes-suffixes)))))  
    jka-compr-compression-info-list)  
   (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  
                (mapcar (lambda (suffix)  
                          (cons suffix  
                                (mapcar (lambda (ext) (concat suffix ext))  
                                        jka-compr-load-suffixes)))  
                        load-suffixes))))  
   
   
673  (defun jka-compr-uninstall ()  (defun jka-compr-uninstall ()
674    "Uninstall jka-compr.    "Uninstall jka-compr.
675  This removes the entries in `file-name-handler-alist' and `auto-mode-alist'  This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
# Line 908  by `jka-compr-installed'." Line 729  by `jka-compr-installed'."
729          (push suffix suffixes)))          (push suffix suffixes)))
730      (setq load-suffixes (nreverse suffixes))))      (setq load-suffixes (nreverse suffixes))))
731    
   
 (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))  
   
   
 ;;; Add the file I/O hook if it does not already exist.  
 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the  
 ;;; entry for jka-compr in file-name-handler-alist.  
 (and (jka-compr-installed-p)  
      (jka-compr-uninstall))  
   
   
 ;;;###autoload  
 (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 :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)))))  
   
   
 ;;;###autoload  
 (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)  
   
   
732  (provide 'jka-compr)  (provide 'jka-compr)
733    
734  ;;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc  ;;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc

Legend:
Removed from v.1.82  
changed lines
  Added in v.1.83

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26