LCOV - code coverage report
Current view: top level - lisp - jka-compr.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 0 351 0.0 %
Date: 2017-08-30 10:12:24 Functions: 0 13 0.0 %

          Line data    Source code
       1             : ;;; jka-compr.el --- reading/writing/loading compressed files
       2             : 
       3             : ;; Copyright (C) 1993-1995, 1997, 1999-2017 Free Software Foundation,
       4             : ;; Inc.
       5             : 
       6             : ;; Author: Jay K. Adams <jka@ece.cmu.edu>
       7             : ;; Maintainer: emacs-devel@gnu.org
       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 package implements low-level support for reading, writing,
      28             : ;; and loading compressed files.  It hooks into the low-level file
      29             : ;; I/O functions (including write-region and insert-file-contents) so
      30             : ;; that they automatically compress or uncompress a file if the file
      31             : ;; appears to need it (based on the extension of the file name).
      32             : ;; Packages like Rmail, VM, GNUS, and Info should be able to work
      33             : ;; with compressed files without modification.
      34             : 
      35             : 
      36             : ;; INSTRUCTIONS:
      37             : ;;
      38             : ;; To use jka-compr, invoke the command `auto-compression-mode' (which
      39             : ;; see), or customize the variable of the same name.  Its operation
      40             : ;; should be transparent to the user (except for messages appearing when
      41             : ;; a file is being compressed or uncompressed).
      42             : ;;
      43             : ;; The variable, jka-compr-compression-info-list can be used to
      44             : ;; customize jka-compr to work with other compression programs.
      45             : ;; The default value of this variable allows jka-compr to work with
      46             : ;; Unix compress and gzip.
      47             : ;;
      48             : ;; If you don't want messages about compressing and decompressing
      49             : ;; to show up in the echo area, you can set the compress-msg and
      50             : ;; decompress-msg fields of the jka-compr-compression-info-list to
      51             : ;; nil.
      52             : 
      53             : 
      54             : ;; APPLICATION NOTES:
      55             : ;;
      56             : ;; crypt++
      57             : ;;   jka-compr can coexist with crypt++ if you take all the decompression
      58             : ;;   entries out of the crypt-encoding-list.  Clearly problems will arise if
      59             : ;;   you have two programs trying to compress/decompress files.  jka-compr
      60             : ;;   will not "work with" crypt++ in the following sense: you won't be able to
      61             : ;;   decode encrypted compressed files--that is, files that have been
      62             : ;;   compressed then encrypted (in that order).  Theoretically, crypt++ and
      63             : ;;   jka-compr could properly handle a file that has been encrypted then
      64             : ;;   compressed, but there is little point in trying to compress an encrypted
      65             : ;;   file.
      66             : ;;
      67             : 
      68             : 
      69             : ;; ACKNOWLEDGMENTS
      70             : ;;
      71             : ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs.  Many people
      72             : ;; have made helpful suggestions, reported bugs, and even fixed bugs in
      73             : ;; jka-compr.  I recall the following people as being particularly helpful.
      74             : ;;
      75             : ;;   Jean-loup Gailly
      76             : ;;   David Hughes
      77             : ;;   Richard Pieri
      78             : ;;   Daniel Quinlan
      79             : ;;   Chris P. Ross
      80             : ;;   Rick Sladkey
      81             : ;;
      82             : ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
      83             : ;; Version 18 of Emacs.
      84             : ;;
      85             : ;; After I had made progress on the original jka-compr for V18, I learned of a
      86             : ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
      87             : ;; what I was trying to do.  I looked over the jam-zcat source code and
      88             : ;; probably got some ideas from it.
      89             : ;;
      90             : 
      91             : ;;; Code:
      92             : 
      93             : (require 'jka-cmpr-hook)
      94             : 
      95             : (defcustom jka-compr-shell "sh"
      96             :   "Shell to be used for calling compression programs.
      97             : NOTE: Not used in MS-DOS and Windows systems."
      98             :   :type 'string
      99             :   :group 'jka-compr)
     100             : 
     101             : (defvar jka-compr-use-shell
     102             :   (not (memq system-type '(ms-dos windows-nt))))
     103             : 
     104             : (defvar jka-compr-really-do-compress nil
     105             :   "Non-nil in a buffer whose visited file was uncompressed on visiting it.
     106             : This means compress the data on writing the file, even if the
     107             : data appears to be compressed already.")
     108             : (make-variable-buffer-local 'jka-compr-really-do-compress)
     109             : (put 'jka-compr-really-do-compress 'permanent-local t)
     110             : 
     111             : 
     112             : (define-error 'compression-error nil 'file-error)
     113             : 
     114             : (defvar jka-compr-acceptable-retval-list '(0 2 141))
     115             : 
     116             : 
     117             : (defun jka-compr-error (prog args infile message &optional errfile)
     118             : 
     119           0 :   (let ((errbuf (get-buffer-create " *jka-compr-error*")))
     120           0 :     (with-current-buffer errbuf
     121           0 :       (widen) (erase-buffer)
     122           0 :       (insert (format "Error while executing \"%s %s < %s\"\n\n"
     123           0 :                       prog
     124           0 :                       (mapconcat 'identity args " ")
     125           0 :                       infile))
     126             : 
     127           0 :       (and errfile
     128           0 :            (insert-file-contents errfile)))
     129           0 :      (display-buffer errbuf))
     130             : 
     131           0 :   (signal 'compression-error
     132           0 :           (list "Opening input file" (format "error %s" message) infile)))
     133             : 
     134             : 
     135             : (defcustom jka-compr-dd-program "/bin/dd"
     136             :   "How to invoke `dd'."
     137             :   :type 'string
     138             :   :group 'jka-compr)
     139             : 
     140             : 
     141             : (defvar jka-compr-dd-blocksize 256)
     142             : 
     143             : 
     144             : (defun jka-compr-partial-uncompress (prog message args infile beg len)
     145             :   "Call program PROG with ARGS args taking input from INFILE.
     146             : Fourth and fifth args, BEG and LEN, specify which part of the output
     147             : to keep: LEN chars starting BEG chars from the beginning."
     148           0 :   (let ((start (point))
     149           0 :         (prefix beg))
     150           0 :     (if (and jka-compr-use-shell jka-compr-dd-program)
     151             :         ;; Put the uncompression output through dd
     152             :         ;; to discard the part we don't want.
     153           0 :         (let ((skip (/ beg jka-compr-dd-blocksize))
     154           0 :               (err-file (jka-compr-make-temp-name))
     155             :               ;; call-process barfs if default-directory is inaccessible.
     156             :               (default-directory
     157           0 :                 (if (and default-directory
     158           0 :                          (file-accessible-directory-p default-directory))
     159           0 :                     default-directory
     160           0 :                   (file-name-directory infile)))
     161             :               count)
     162             :           ;; Update PREFIX based on the text that we won't read in.
     163           0 :           (setq prefix (- beg (* skip jka-compr-dd-blocksize))
     164           0 :                 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
     165           0 :           (unwind-protect
     166           0 :               (or (memq (call-process
     167           0 :                          jka-compr-shell infile t nil "-c"
     168             :                          ;; Windows shells need the program file name
     169             :                          ;; after the pipe symbol be quoted if they use
     170             :                          ;; forward slashes as directory separators.
     171           0 :                          (format
     172             :                           "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
     173           0 :                           prog
     174           0 :                           (mapconcat 'identity args " ")
     175           0 :                           err-file
     176           0 :                           jka-compr-dd-program
     177           0 :                           jka-compr-dd-blocksize
     178           0 :                           skip
     179             :                           ;; dd seems to be unreliable about
     180             :                           ;; providing the last block.  So, always
     181             :                           ;; read one more than you think you need.
     182           0 :                           (if count (format "count=%d" (1+ count)) "")
     183           0 :                           null-device))
     184           0 :                         jka-compr-acceptable-retval-list)
     185           0 :                   (jka-compr-error prog args infile message err-file))
     186           0 :             (delete-file err-file)))
     187             : 
     188             :       ;; Run the uncompression program directly.
     189             :       ;; We get the whole file and must delete what we don't want.
     190           0 :       (jka-compr-call-process prog message infile t nil args))
     191             : 
     192             :     ;; Delete the stuff after what we want, if there is any.
     193           0 :     (and
     194           0 :      len
     195           0 :      (< (+ start prefix len) (point))
     196           0 :      (delete-region (+ start prefix len) (point)))
     197             : 
     198             :     ;; Delete the stuff before what we want.
     199           0 :     (delete-region start (+ start prefix))))
     200             : 
     201             : 
     202             : (defun jka-compr-call-process (prog message infile output temp args)
     203             :   ;; call-process barfs if default-directory is inaccessible.
     204           0 :   (let ((default-directory
     205           0 :           (if (and default-directory
     206           0 :                    (not (file-remote-p default-directory))
     207           0 :                    (file-accessible-directory-p default-directory))
     208           0 :               default-directory
     209           0 :             (file-name-directory infile))))
     210           0 :     (if jka-compr-use-shell
     211           0 :         (let ((err-file (jka-compr-make-temp-name))
     212           0 :               (coding-system-for-read (or coding-system-for-read 'undecided))
     213             :               (coding-system-for-write 'no-conversion))
     214           0 :           (unwind-protect
     215           0 :               (or (memq
     216           0 :                    (call-process jka-compr-shell infile
     217           0 :                                  (if (stringp output) nil output)
     218             :                                  nil
     219             :                                  "-c"
     220           0 :                                  (format "%s %s 2> %s %s"
     221           0 :                                          prog
     222           0 :                                          (mapconcat 'identity args " ")
     223           0 :                                          err-file
     224           0 :                                          (if (stringp output)
     225           0 :                                              (concat "> " output)
     226           0 :                                            "")))
     227           0 :                    jka-compr-acceptable-retval-list)
     228           0 :                   (jka-compr-error prog args infile message err-file))
     229           0 :             (delete-file err-file)))
     230           0 :       (or (eq 0
     231           0 :               (apply 'call-process
     232           0 :                      prog infile (if (stringp output) temp output)
     233           0 :                      nil args))
     234           0 :           (jka-compr-error prog args infile message))
     235           0 :       (and (stringp output)
     236           0 :            (with-current-buffer temp
     237           0 :              (write-region (point-min) (point-max) output)
     238           0 :              (erase-buffer))))))
     239             : 
     240             : 
     241             : ;; Support for temp files.  Much of this was inspired if not lifted
     242             : ;; from ange-ftp.
     243             : 
     244             : (defcustom jka-compr-temp-name-template
     245             :   (expand-file-name "jka-com" temporary-file-directory)
     246             :   "Prefix added to all temp files created by jka-compr.
     247             : There should be no more than seven characters after the final `/'."
     248             :   :type 'string
     249             :   :group 'jka-compr)
     250             : 
     251             : (defun jka-compr-make-temp-name (&optional _local-copy)
     252             :   "This routine will return the name of a new file."
     253           0 :   (make-temp-file jka-compr-temp-name-template))
     254             : 
     255             : (defun jka-compr-write-region (start end file &optional
     256             :                                      append visit lockname mustbenew)
     257           0 :   (let* ((filename (expand-file-name file))
     258           0 :          (visit-file (if (stringp visit) (expand-file-name visit) filename))
     259           0 :          (info (jka-compr-get-compression-info visit-file))
     260           0 :          (magic (and info (jka-compr-info-file-magic-bytes info))))
     261             : 
     262             :     ;; If we uncompressed this file when visiting it,
     263             :     ;; then recompress it when writing it
     264             :     ;; even if the contents look compressed already.
     265           0 :     (if (and jka-compr-really-do-compress
     266           0 :              (or (null start)
     267           0 :                  (= (- end start) (buffer-size))))
     268           0 :         (setq magic nil))
     269             : 
     270           0 :     (if (and info
     271             :              ;; If the contents to be written out
     272             :              ;; are properly compressed already,
     273             :              ;; don't try to compress them over again.
     274           0 :              (not (and magic
     275           0 :                        (equal (if (stringp start)
     276           0 :                                   (substring start 0 (min (length start)
     277           0 :                                                           (length magic)))
     278           0 :                                 (let* ((from (or start (point-min)))
     279           0 :                                        (to (min (or end (point-max))
     280           0 :                                                 (+ from (length magic)))))
     281           0 :                                   (buffer-substring from to)))
     282           0 :                               magic))))
     283           0 :         (let ((can-append (jka-compr-info-can-append info))
     284           0 :               (compress-program (jka-compr-info-compress-program info))
     285           0 :               (compress-message (jka-compr-info-compress-message info))
     286           0 :               (compress-args (jka-compr-info-compress-args info))
     287           0 :               (base-name (file-name-nondirectory visit-file))
     288             :               temp-file temp-buffer
     289             :               ;; we need to leave `last-coding-system-used' set to its
     290             :               ;; value after calling write-region the first time, so
     291             :               ;; that `basic-save-buffer' sees the right value.
     292           0 :               (coding-system-used last-coding-system-used))
     293             : 
     294           0 :           (or compress-program
     295           0 :               (error "No compression program defined"))
     296             : 
     297           0 :           (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
     298           0 :           (with-current-buffer temp-buffer
     299           0 :             (widen) (erase-buffer))
     300             : 
     301           0 :           (if (and append
     302           0 :                    (not can-append)
     303           0 :                    (file-exists-p filename))
     304             : 
     305           0 :               (let* ((local-copy (file-local-copy filename))
     306           0 :                      (local-file (or local-copy filename)))
     307             : 
     308           0 :                 (setq temp-file local-file))
     309             : 
     310           0 :             (setq temp-file (jka-compr-make-temp-name)))
     311             : 
     312           0 :           (and
     313           0 :            compress-message
     314           0 :            jka-compr-verbose
     315           0 :            (message "%s %s..." compress-message base-name))
     316             : 
     317           0 :           (jka-compr-run-real-handler 'write-region
     318           0 :                                       (list start end temp-file t 'dont))
     319             :           ;; save value used by the real write-region
     320           0 :           (setq coding-system-used last-coding-system-used)
     321             : 
     322             :           ;; Here we must read the output of compress program as is
     323             :           ;; without any code conversion.
     324           0 :           (let ((coding-system-for-read 'no-conversion))
     325           0 :             (jka-compr-call-process compress-program
     326           0 :                                     (concat compress-message
     327           0 :                                             " " base-name)
     328           0 :                                     temp-file
     329           0 :                                     temp-buffer
     330             :                                     nil
     331           0 :                                     compress-args))
     332             : 
     333           0 :           (with-current-buffer temp-buffer
     334           0 :             (let ((coding-system-for-write 'no-conversion))
     335           0 :               (jka-compr-run-real-handler 'write-region
     336           0 :                                           (list (point-min) (point-max)
     337           0 :                                                 filename
     338           0 :                                                 (and append can-append) 'dont
     339           0 :                                                 lockname mustbenew))
     340           0 :               (erase-buffer)) )
     341             : 
     342           0 :           (delete-file temp-file)
     343             : 
     344           0 :           (and
     345           0 :            compress-message
     346           0 :            jka-compr-verbose
     347           0 :            (message "%s %s...done" compress-message base-name))
     348             : 
     349           0 :           (cond
     350           0 :            ((eq visit t)
     351           0 :             (setq buffer-file-name filename)
     352           0 :             (setq jka-compr-really-do-compress t)
     353           0 :             (set-visited-file-modtime))
     354           0 :            ((stringp visit)
     355           0 :             (setq buffer-file-name visit)
     356           0 :             (let ((buffer-file-name filename))
     357           0 :               (set-visited-file-modtime))))
     358             : 
     359           0 :           (and (or (eq visit t)
     360           0 :                    (eq visit nil)
     361           0 :                    (stringp visit))
     362           0 :                (message "Wrote %s" visit-file))
     363             : 
     364             :           ;; ensure `last-coding-system-used' has an appropriate value
     365           0 :           (setq last-coding-system-used coding-system-used)
     366             : 
     367           0 :           nil)
     368             : 
     369           0 :       (jka-compr-run-real-handler 'write-region
     370           0 :                                   (list start end filename append visit
     371           0 :                                         lockname mustbenew)))))
     372             : 
     373             : 
     374             : (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
     375           0 :   (barf-if-buffer-read-only)
     376             : 
     377           0 :   (and (or beg end)
     378           0 :        visit
     379           0 :        (error "Attempt to visit less than an entire file"))
     380             : 
     381           0 :   (let* ((filename (expand-file-name file))
     382           0 :          (info (jka-compr-get-compression-info filename)))
     383             : 
     384           0 :     (if (not info)
     385             : 
     386           0 :         (jka-compr-run-real-handler 'insert-file-contents
     387           0 :                                     (list file visit beg end replace))
     388             : 
     389           0 :       (let ((uncompress-message (jka-compr-info-uncompress-message info))
     390           0 :             (uncompress-program (jka-compr-info-uncompress-program info))
     391           0 :             (uncompress-args (jka-compr-info-uncompress-args info))
     392           0 :             (base-name (file-name-nondirectory filename))
     393             :             (notfound nil)
     394             :             (local-copy
     395           0 :              (jka-compr-run-real-handler 'file-local-copy (list filename)))
     396             :             local-file
     397             :             size start)
     398             : 
     399           0 :         (setq local-file (or local-copy filename))
     400             : 
     401           0 :         (and
     402           0 :          visit
     403           0 :          (setq buffer-file-name filename))
     404             : 
     405           0 :         (unwind-protect               ; to make sure local-copy gets deleted
     406             : 
     407           0 :             (progn
     408             : 
     409           0 :               (and
     410           0 :                uncompress-message
     411           0 :                jka-compr-verbose
     412           0 :                (message "%s %s..." uncompress-message base-name))
     413             : 
     414           0 :               (condition-case error-code
     415             : 
     416           0 :                   (let ((coding-system-for-read 'no-conversion))
     417           0 :                     (if replace
     418           0 :                         (goto-char (point-min)))
     419           0 :                     (setq start (point))
     420           0 :                     (if (or beg end)
     421           0 :                         (jka-compr-partial-uncompress uncompress-program
     422           0 :                                                       (concat uncompress-message
     423           0 :                                                               " " base-name)
     424           0 :                                                       uncompress-args
     425           0 :                                                       local-file
     426           0 :                                                       (or beg 0)
     427           0 :                                                       (if (and beg end)
     428           0 :                                                           (- end beg)
     429           0 :                                                         end))
     430             :                       ;; If visiting, bind off buffer-file-name so that
     431             :                       ;; file-locking will not ask whether we should
     432             :                       ;; really edit the buffer.
     433           0 :                       (let ((buffer-file-name
     434           0 :                              (if visit nil buffer-file-name)))
     435           0 :                         (jka-compr-call-process uncompress-program
     436           0 :                                                 (concat uncompress-message
     437           0 :                                                         " " base-name)
     438           0 :                                                 local-file
     439             :                                                 t
     440             :                                                 nil
     441           0 :                                                 uncompress-args)))
     442           0 :                     (setq size (- (point) start))
     443           0 :                     (if replace
     444           0 :                         (delete-region (point) (point-max)))
     445           0 :                     (goto-char start))
     446             :                 (error
     447             :                  ;; If the file we wanted to uncompress does not exist,
     448             :                  ;; handle that according to VISIT as `insert-file-contents'
     449             :                  ;; would, maybe signaling the same error it normally would.
     450           0 :                  (if (and (eq (car error-code) 'file-missing)
     451           0 :                           (eq (nth 3 error-code) local-file))
     452           0 :                      (if visit
     453           0 :                          (setq notfound error-code)
     454           0 :                        (signal 'file-missing
     455           0 :                                (cons "Opening input file"
     456           0 :                                      (nthcdr 2 error-code))))
     457             :                    ;; If the uncompression program can't be found,
     458             :                    ;; signal that as a non-file error
     459             :                    ;; so that find-file-noselect-1 won't handle it.
     460           0 :                    (if (and (memq 'file-error (get (car error-code)
     461           0 :                                                    'error-conditions))
     462           0 :                             (equal (cadr error-code) "Searching for program"))
     463           0 :                        (error "Uncompression program `%s' not found"
     464           0 :                               (nth 3 error-code)))
     465           0 :                    (signal (car error-code) (cdr error-code))))))
     466             : 
     467           0 :           (and
     468           0 :            local-copy
     469           0 :            (file-exists-p local-copy)
     470           0 :            (delete-file local-copy)))
     471             : 
     472           0 :         (unless notfound
     473           0 :           (decode-coding-inserted-region
     474           0 :            (point) (+ (point) size)
     475           0 :            (jka-compr-byte-compiler-base-file-name file)
     476           0 :            visit beg end replace))
     477             : 
     478           0 :         (and
     479           0 :          visit
     480           0 :          (progn
     481           0 :            (unlock-buffer)
     482           0 :            (setq buffer-file-name filename)
     483           0 :            (setq jka-compr-really-do-compress t)
     484           0 :            (set-visited-file-modtime)))
     485             : 
     486           0 :         (and
     487           0 :          uncompress-message
     488           0 :          jka-compr-verbose
     489           0 :          (message "%s %s...done" uncompress-message base-name))
     490             : 
     491           0 :         (and
     492           0 :          visit
     493           0 :          notfound
     494           0 :          (signal 'file-missing
     495           0 :                  (cons "Opening input file" (nth 2 notfound))))
     496             : 
     497             :         ;; This is done in insert-file-contents after we return.
     498             :         ;; That is a little weird, but better to go along with it now
     499             :         ;; than to change it now.
     500             : 
     501             :         ;; ;; Run the functions that insert-file-contents would.
     502             :         ;; (let ((p after-insert-file-functions)
     503             :         ;;       (insval size))
     504             :         ;;   (while p
     505             :         ;;     (setq insval (funcall (car p) size))
     506             :         ;;     (if insval
     507             :         ;;         (progn
     508             :         ;;           (or (integerp insval)
     509             :         ;;              (signal 'wrong-type-argument
     510             :         ;;                      (list 'integerp insval)))
     511             :         ;;           (setq size insval)))
     512             :         ;;     (setq p (cdr p))))
     513             : 
     514           0 :         (or (jka-compr-info-compress-program info)
     515           0 :             (message "You can't save this buffer because compression program is not defined"))
     516             : 
     517           0 :         (list filename size)))))
     518             : 
     519             : 
     520             : (defun jka-compr-file-local-copy (file)
     521           0 :   (let* ((filename (expand-file-name file))
     522           0 :          (info (jka-compr-get-compression-info filename)))
     523             : 
     524           0 :     (if info
     525             : 
     526           0 :         (let ((uncompress-message (jka-compr-info-uncompress-message info))
     527           0 :               (uncompress-program (jka-compr-info-uncompress-program info))
     528           0 :               (uncompress-args (jka-compr-info-uncompress-args info))
     529           0 :               (base-name (file-name-nondirectory filename))
     530             :               (local-copy
     531           0 :                (jka-compr-run-real-handler 'file-local-copy (list filename)))
     532           0 :               (temp-file (jka-compr-make-temp-name t))
     533           0 :               (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
     534             :               local-file)
     535             : 
     536           0 :           (setq local-file (or local-copy filename))
     537             : 
     538           0 :           (unwind-protect
     539             : 
     540           0 :               (with-current-buffer temp-buffer
     541             : 
     542           0 :                 (and
     543           0 :                  uncompress-message
     544           0 :                  jka-compr-verbose
     545           0 :                  (message "%s %s..." uncompress-message base-name))
     546             : 
     547             :                 ;; Here we must read the output of uncompress program
     548             :                 ;; and write it to TEMP-FILE without any code
     549             :                 ;; conversion.  An appropriate code conversion (if
     550             :                 ;; necessary) is done by the later I/O operation
     551             :                 ;; (e.g. load).
     552           0 :                 (let ((coding-system-for-read 'no-conversion)
     553             :                       (coding-system-for-write 'no-conversion))
     554             : 
     555           0 :                   (jka-compr-call-process uncompress-program
     556           0 :                                           (concat uncompress-message
     557           0 :                                                   " " base-name)
     558           0 :                                           local-file
     559             :                                           t
     560             :                                           nil
     561           0 :                                           uncompress-args)
     562             : 
     563           0 :                   (and
     564           0 :                    uncompress-message
     565           0 :                    jka-compr-verbose
     566           0 :                    (message "%s %s...done" uncompress-message base-name))
     567             : 
     568           0 :                   (write-region
     569           0 :                    (point-min) (point-max) temp-file nil 'dont)))
     570             : 
     571           0 :             (and
     572           0 :              local-copy
     573           0 :              (file-exists-p local-copy)
     574           0 :              (delete-file local-copy))
     575             : 
     576           0 :             (kill-buffer temp-buffer))
     577             : 
     578           0 :           temp-file)
     579             : 
     580           0 :       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
     581             : 
     582             : 
     583             : ;; Support for loading compressed files.
     584             : (defun jka-compr-load (file &optional noerror nomessage _nosuffix)
     585             :   "Documented as original."
     586             : 
     587           0 :   (let* ((local-copy (jka-compr-file-local-copy file))
     588           0 :          (load-file (or local-copy file)))
     589             : 
     590           0 :     (unwind-protect
     591             : 
     592           0 :         (let (inhibit-file-name-operation
     593             :               inhibit-file-name-handlers)
     594           0 :           (or nomessage
     595           0 :               (message "Loading %s..." file))
     596             : 
     597           0 :           (let ((load-force-doc-strings t))
     598           0 :             (load load-file noerror t t))
     599           0 :           (or nomessage
     600           0 :               (message "Loading %s...done." file))
     601             :           ;; Fix up the load history to point at the right library.
     602           0 :           (let ((l (or (assoc load-file load-history)
     603             :                        ;; On MS-Windows, if load-file is in
     604             :                        ;; temporary-file-directory, it will look like
     605             :                        ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas
     606             :                        ;; readevalloop will record its truename in
     607             :                        ;; load-history.  Therefore try truename if the
     608             :                        ;; original name is not in load-history.
     609           0 :                        (assoc (file-truename load-file) load-history))))
     610             :             ;; Remove .gz and .elc?.
     611           0 :             (while (file-name-extension file)
     612           0 :               (setq file (file-name-sans-extension file)))
     613           0 :             (setcar l file)))
     614             : 
     615           0 :       (delete-file local-copy))
     616             : 
     617           0 :     t))
     618             : 
     619             : (defun jka-compr-byte-compiler-base-file-name (file)
     620           0 :   (let ((info (jka-compr-get-compression-info file)))
     621           0 :     (if (and info (jka-compr-info-strip-extension info))
     622           0 :         (save-match-data
     623           0 :           (substring file 0 (string-match (jka-compr-info-regexp info) file)))
     624           0 :       file)))
     625             : 
     626             : (put 'write-region 'jka-compr 'jka-compr-write-region)
     627             : (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
     628             : (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
     629             : (put 'load 'jka-compr 'jka-compr-load)
     630             : (put 'byte-compiler-base-file-name 'jka-compr
     631             :      'jka-compr-byte-compiler-base-file-name)
     632             : 
     633             : ;;;###autoload
     634             : (defvar jka-compr-inhibit nil
     635             :   "Non-nil means inhibit automatic uncompression temporarily.
     636             : Lisp programs can bind this to t to do that.
     637             : It is not recommended to set this variable permanently to anything but nil.")
     638             : 
     639             : ;;;###autoload
     640             : (defun jka-compr-handler (operation &rest args)
     641           0 :   (save-match-data
     642           0 :     (let ((jka-op (get operation 'jka-compr)))
     643           0 :       (if (and jka-op (not jka-compr-inhibit))
     644           0 :           (apply jka-op args)
     645           0 :         (jka-compr-run-real-handler operation args)))))
     646             : 
     647             : ;; If we are given an operation that we don't handle,
     648             : ;; call the Emacs primitive for that operation,
     649             : ;; and manipulate the inhibit variables
     650             : ;; to prevent the primitive from calling our handler again.
     651             : (defun jka-compr-run-real-handler (operation args)
     652           0 :   (let ((inhibit-file-name-handlers
     653           0 :          (cons 'jka-compr-handler
     654           0 :                (and (eq inhibit-file-name-operation operation)
     655           0 :                     inhibit-file-name-handlers)))
     656           0 :         (inhibit-file-name-operation operation))
     657           0 :     (apply operation args)))
     658             : 
     659             : ;;;###autoload
     660             : (defun jka-compr-uninstall ()
     661             :   "Uninstall jka-compr.
     662             : This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
     663             : and `inhibit-local-variables-suffixes' that were added
     664             : by `jka-compr-installed'."
     665             :   ;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
     666           0 :   (mapc
     667           0 :      (function (lambda (x)
     668           0 :                  (and (jka-compr-info-strip-extension x)
     669           0 :                       (setq inhibit-local-variables-suffixes
     670           0 :                             (delete (jka-compr-info-regexp x)
     671           0 :                                     inhibit-local-variables-suffixes)))))
     672           0 :      jka-compr-compression-info-list--internal)
     673             : 
     674           0 :   (let* ((fnha (cons nil file-name-handler-alist))
     675           0 :          (last fnha))
     676             : 
     677           0 :     (while (cdr last)
     678           0 :       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
     679           0 :           (setcdr last (cdr (cdr last)))
     680           0 :         (setq last (cdr last))))
     681             : 
     682           0 :     (setq file-name-handler-alist (cdr fnha)))
     683             : 
     684           0 :   (let* ((ama (cons nil auto-mode-alist))
     685           0 :          (last ama)
     686             :          entry)
     687             : 
     688           0 :     (while (cdr last)
     689           0 :       (setq entry (car (cdr last)))
     690           0 :       (if (or (member entry jka-compr-mode-alist-additions--internal)
     691           0 :               (and (consp (cdr entry))
     692           0 :                    (eq (nth 2 entry) 'jka-compr)))
     693           0 :           (setcdr last (cdr (cdr last)))
     694           0 :         (setq last (cdr last))))
     695             : 
     696           0 :     (setq auto-mode-alist (cdr ama)))
     697             : 
     698           0 :   (while jka-compr-added-to-file-coding-system-alist
     699           0 :     (setq file-coding-system-alist
     700           0 :           (delq (car (member (pop jka-compr-added-to-file-coding-system-alist)
     701           0 :                              file-coding-system-alist))
     702           0 :                 file-coding-system-alist)))
     703             : 
     704             :   ;; Remove the suffixes that were added by jka-compr.
     705           0 :   (dolist (suff jka-compr-load-suffixes--internal)
     706           0 :     (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes)))
     707             : 
     708           0 :   (setq jka-compr-compression-info-list--internal nil
     709             :         jka-compr-mode-alist-additions--internal nil
     710           0 :         jka-compr-load-suffixes--internal nil))
     711             : 
     712             : (provide 'jka-compr)
     713             : 
     714             : ;;; jka-compr.el ends here

Generated by: LCOV version 1.12