Mercurial > emacs
annotate lisp/jka-compr.el @ 91817:f0b22bbb77fb
;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
;; Maintainer: Simon Josefsson <simon@josefsson.org>
;; w32 Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
;; ESMTP support: Simon Leinen <simon@switch.ch>
;; Hacked by Mike Taylor, 11th October 1999 to add support for
;; automatically appending a domain to RCPT TO: addresses.
;; AUTH=LOGIN support: Stephen Cranefield <scranefield@infoscience.otago.ac.nz>
;; Keywords: mail
;; 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 3, 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:
;; Send Mail to smtp host from smtpmail temp buffer.
;; Please add these lines in your .emacs(_emacs) or use customize.
;;
;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail'
;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus
;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME")
;;(setq smtpmail-debug-info t) ; only to debug problems
;;(setq smtpmail-auth-credentials ; or use ~/.authinfo
;; '(("YOUR SMTP HOST" 25 "username" "password")))
;;(setq smtpmail-starttls-credentials
;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert")))
;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an
;; integer or a string, just as long as they match (eq).
;; To queue mail, set smtpmail-queue-mail to t and use
;; smtpmail-send-queued-mail to send.
;; Modified by Stephen Cranefield <scranefield@infoscience.otago.ac.nz>,
;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism.
;; See http://help.netscape.com/products/server/messaging/3x/info/smtpauth.html
;; Rewritten by Simon Josefsson to use same credential variable as AUTH
;; support below.
;; Modified by Simon Josefsson <jas@pdc.kth.se>, 22/2/99, to support SMTP
;; Authentication by the AUTH mechanism.
;; See http://www.ietf.org/rfc/rfc2554.txt
;; Modified by Simon Josefsson <simon@josefsson.org>, 2000-10-07, to support
;; STARTTLS. Requires external program
;; ftp://ftp.opaopa.org/pub/elisp/starttls-*.tar.gz.
;; See http://www.ietf.org/rfc/rfc2246.txt, http://www.ietf.org/rfc/rfc2487.txt
;;; Code:
(require 'sendmail)
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'mail-strip-quoted-names "mail-utils")
(autoload 'message-make-date "message")
(autoload 'message-make-message-id "message")
(autoload 'rfc2104-hash "rfc2104")
(autoload 'netrc-parse "netrc")
(autoload 'netrc-machine "netrc")
(autoload 'netrc-get "netrc")
;;;
(defgroup smtpmail nil
"SMTP protocol for sending mail."
:group 'mail)
(defcustom smtpmail-default-smtp-server nil
"*Specify default SMTP server.
This only has effect if you specify it before loading the smtpmail library."
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-smtp-server
(or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
"*The name of the host running SMTP server."
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-smtp-service 25
"*SMTP service port number.
The default value would be \"smtp\" or 25."
:type '(choice (integer :tag "Port") (string :tag "Service"))
:group 'smtpmail)
(defcustom smtpmail-local-domain nil
"*Local domain name without a host name.
If the function `system-name' returns the full internet address,
don't define this value."
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-sendto-domain nil
"*Local domain name without a host name.
This is appended (with an @-sign) to any specified recipients which do
not include an @-sign, so that each RCPT TO address is fully qualified.
\(Some configurations of sendmail require this.)
Don't bother to set this unless you have get an error like:
Sending failed; SMTP protocol error
when sending mail, and the *trace of SMTP session to <somewhere>*
buffer includes an exchange like:
RCPT TO: <someone>
501 <someone>: recipient address must contain a domain
"
:type '(choice (const nil) string)
:group 'smtpmail)
(defcustom smtpmail-debug-info nil
"Whether to print info in buffer *trace of SMTP session to <somewhere>*.
See also `smtpmail-debug-verb' which determines if the SMTP protocol should
be verbose as well."
:type 'boolean
:group 'smtpmail)
(defcustom smtpmail-debug-verb nil
"Whether this library sends the SMTP VERB command or not.
The commands enables verbose information from the SMTP server."
:type 'boolean
:group 'smtpmail)
(defcustom smtpmail-code-conv-from nil ;; *junet*
"*smtpmail code convert from this code to *internal*..for tiny-mime.."
:type 'boolean
:group 'smtpmail)
(defcustom smtpmail-queue-mail nil
"*If set, mail is queued; otherwise it is sent immediately.
If queued, it is stored in the directory `smtpmail-queue-dir'
and sent with `smtpmail-send-queued-mail'."
:type 'boolean
:group 'smtpmail)
(defcustom smtpmail-queue-dir "~/Mail/queued-mail/"
"*Directory where `smtpmail.el' stores queued mail."
:type 'directory
:group 'smtpmail)
(defcustom smtpmail-auth-credentials "~/.authinfo"
"Specify username and password for servers, directly or via .netrc file.
This variable can either be a filename pointing to a file in netrc(5)
format, or list of four-element lists that contain, in order,
`servername' (a string), `port' (an integer), `user' (a string) and
`password' (a string, or nil to query the user when needed). If you
need to enter a `realm' too, add it to the user string, so that it
looks like `user@realm'."
:type '(choice file
(repeat (list (string :tag "Server")
(integer :tag "Port")
(string :tag "Username")
(choice (const :tag "Query when needed" nil)
(string :tag "Password")))))
:version "22.1"
:group 'smtpmail)
(defcustom smtpmail-starttls-credentials '(("" 25 "" ""))
"Specify STARTTLS keys and certificates for servers.
This is a list of four-element list with `servername' (a string),
`port' (an integer), `key' (a filename) and `certificate' (a
filename).
If you do not have a certificate/key pair, leave the `key' and
`certificate' fields as `nil'. A key/certificate pair is only
needed if you want to use X.509 client authenticated
connections."
:type '(repeat (list (string :tag "Server")
(integer :tag "Port")
(file :tag "Key")
(file :tag "Certificate")))
:version "21.1"
:group 'smtpmail)
(defcustom smtpmail-warn-about-unknown-extensions nil
"*If set, print warnings about unknown SMTP extensions.
This is mainly useful for development purposes, to learn about
new SMTP extensions that might be useful to support."
:type 'boolean
:version "21.1"
:group 'smtpmail)
(defvar smtpmail-queue-index-file "index"
"File name of queued mail index.
This is relative to `smtpmail-queue-dir'.")
(defvar smtpmail-address-buffer)
(defvar smtpmail-recipient-address-list)
(defvar smtpmail-queue-counter 0)
;; Buffer-local variable.
(defvar smtpmail-read-point)
(defvar smtpmail-queue-index (concat smtpmail-queue-dir
smtpmail-queue-index-file))
(defconst smtpmail-auth-supported '(cram-md5 plain login)
"List of supported SMTP AUTH mechanisms.")
;;;
;;;
;;;
(defvar smtpmail-mail-address nil
"Value to use for envelope-from address for mail from ambient buffer.")
;;;###autoload
(defun smtpmail-send-it ()
(let ((errbuf (if mail-interactive
(generate-new-buffer " smtpmail errors")
0))
(tembuf (generate-new-buffer " smtpmail temp"))
(case-fold-search nil)
delimline
(mailbuf (current-buffer))
;; Examine this variable now, so that
;; local binding in the mail buffer will take effect.
(smtpmail-mail-address
(or (and mail-specify-envelope-from (mail-envelope-from))
user-mail-address))
(smtpmail-code-conv-from
(if enable-multibyte-characters
(let ((sendmail-coding-system smtpmail-code-conv-from))
(select-message-coding-system)))))
(unwind-protect
(save-excursion
(set-buffer tembuf)
(erase-buffer)
;; Use the same buffer-file-coding-system as in the mail
;; buffer, otherwise any write-region invocations (e.g., in
;; mail-do-fcc below) will annoy with asking for a suitable
;; encoding.
(set-buffer-file-coding-system smtpmail-code-conv-from nil t)
(insert-buffer-substring mailbuf)
(goto-char (point-max))
;; require one newline at the end.
(or (= (preceding-char) ?\n)
(insert ?\n))
;; Change header-delimiter to be what sendmail expects.
(mail-sendmail-undelimit-header)
(setq delimline (point-marker))
;; (sendmail-synch-aliases)
(if mail-aliases
(expand-mail-aliases (point-min) delimline))
(goto-char (point-min))
;; ignore any blank lines in the header
(while (and (re-search-forward "\n\n\n*" delimline t)
(< (point) delimline))
(replace-match "\n"))
(let ((case-fold-search t))
;; We used to process Resent-... headers here,
;; but it was not done properly, and the job
;; is done correctly in smtpmail-deduce-address-list.
;; Don't send out a blank subject line
(goto-char (point-min))
(if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t)
(replace-match "")
;; This one matches a Subject just before the header delimiter.
(if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t)
(= (match-end 0) delimline))
(replace-match "")))
;; Put the "From:" field in unless for some odd reason
;; they put one in themselves.
(goto-char (point-min))
(if (not (re-search-forward "^From:" delimline t))
(let* ((login smtpmail-mail-address)
(fullname (user-full-name)))
(cond ((eq mail-from-style 'angles)
(insert "From: " fullname)
(let ((fullname-start (+ (point-min) 6))
(fullname-end (point-marker)))
(goto-char fullname-start)
;; Look for a character that cannot appear unquoted
;; according to RFC 822.
(if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
fullname-end 1)
(progn
;; Quote fullname, escaping specials.
(goto-char fullname-start)
(insert "\"")
(while (re-search-forward "[\"\\]"
fullname-end 1)
(replace-match "\\\\\\&" t))
(insert "\""))))
(insert " <" login ">\n"))
((eq mail-from-style 'parens)
(insert "From: " login " (")
(let ((fullname-start (point)))
(insert fullname)
(let ((fullname-end (point-marker)))
(goto-char fullname-start)
;; RFC 822 says \ and nonmatching parentheses
;; must be escaped in comments.
;; Escape every instance of ()\ ...
(while (re-search-forward "[()\\]" fullname-end 1)
(replace-match "\\\\\\&" t))
;; ... then undo escaping of matching parentheses,
;; including matching nested parentheses.
(goto-char fullname-start)
(while (re-search-forward
"\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
fullname-end 1)
(replace-match "\\1(\\3)" t)
(goto-char fullname-start))))
(insert ")\n"))
((null mail-from-style)
(insert "From: " login "\n")))))
;; Insert a `Message-Id:' field if there isn't one yet.
(goto-char (point-min))
(unless (re-search-forward "^Message-Id:" delimline t)
(insert "Message-Id: " (message-make-message-id) "\n"))
;; Insert a `Date:' field if there isn't one yet.
(goto-char (point-min))
(unless (re-search-forward "^Date:" delimline t)
(insert "Date: " (message-make-date) "\n"))
;; Possibly add a MIME header for the current coding system
(let (charset)
(goto-char (point-min))
(and (eq mail-send-nonascii 'mime)
(not (re-search-forward "^MIME-version:" delimline t))
(progn (skip-chars-forward "\0-\177")
(/= (point) (point-max)))
smtpmail-code-conv-from
(setq charset
(coding-system-get smtpmail-code-conv-from
'mime-charset))
(goto-char delimline)
(insert "MIME-version: 1.0\n"
"Content-type: text/plain; charset="
(symbol-name charset)
"\nContent-Transfer-Encoding: 8bit\n")))
;; Insert an extra newline if we need it to work around
;; Sun's bug that swallows newlines.
(goto-char (1+ delimline))
(if (eval mail-mailer-swallows-blank-line)
(newline))
;; Find and handle any FCC fields.
(goto-char (point-min))
(if (re-search-forward "^FCC:" delimline t)
;; Force mail-do-fcc to use the encoding of the mail
;; buffer to encode outgoing messages on FCC files.
(let ((coding-system-for-write smtpmail-code-conv-from))
(mail-do-fcc delimline)))
(if mail-interactive
(with-current-buffer errbuf
(erase-buffer))))
;;
;;
;;
(setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
(setq smtpmail-recipient-address-list
(smtpmail-deduce-address-list tembuf (point-min) delimline))
(kill-buffer smtpmail-address-buffer)
(smtpmail-do-bcc delimline)
; Send or queue
(if (not smtpmail-queue-mail)
(if (not (null smtpmail-recipient-address-list))
(if (not (smtpmail-via-smtp
smtpmail-recipient-address-list tembuf))
(error "Sending failed; SMTP protocol error"))
(error "Sending failed; no recipients"))
(let* ((file-data
(expand-file-name
(format "%s_%i"
(format-time-string "%Y-%m-%d_%H:%M:%S")
(setq smtpmail-queue-counter
(1+ smtpmail-queue-counter)))
smtpmail-queue-dir))
(file-data (convert-standard-filename file-data))
(file-elisp (concat file-data ".el"))
(buffer-data (create-file-buffer file-data))
(buffer-elisp (create-file-buffer file-elisp))
(buffer-scratch "*queue-mail*"))
(unless (file-exists-p smtpmail-queue-dir)
(make-directory smtpmail-queue-dir t))
(with-current-buffer buffer-data
(erase-buffer)
(set-buffer-file-coding-system smtpmail-code-conv-from nil t)
(insert-buffer-substring tembuf)
(write-file file-data)
(set-buffer buffer-elisp)
(erase-buffer)
(insert (concat
"(setq smtpmail-recipient-address-list '"
(prin1-to-string smtpmail-recipient-address-list)
")\n"))
(write-file file-elisp)
(set-buffer (generate-new-buffer buffer-scratch))
(insert (concat file-data "\n"))
(append-to-file (point-min)
(point-max)
smtpmail-queue-index)
)
(kill-buffer buffer-scratch)
(kill-buffer buffer-data)
(kill-buffer buffer-elisp))))
(kill-buffer tembuf)
(if (bufferp errbuf)
(kill-buffer errbuf)))))
;;;###autoload
(defun smtpmail-send-queued-mail ()
"Send mail that was queued as a result of setting `smtpmail-queue-mail'."
(interactive)
(with-temp-buffer
;;; Get index, get first mail, send it, update index, get second
;;; mail, send it, etc...
(let ((file-msg ""))
(insert-file-contents smtpmail-queue-index)
(goto-char (point-min))
(while (not (eobp))
(setq file-msg (buffer-substring (point) (line-end-position)))
(load file-msg)
;; Insert the message literally: it is already encoded as per
;; the MIME headers, and code conversions might guess the
;; encoding wrongly.
(with-temp-buffer
(let ((coding-system-for-read 'no-conversion))
(insert-file-contents file-msg))
(let ((smtpmail-mail-address
(or (and mail-specify-envelope-from (mail-envelope-from))
user-mail-address)))
(if (not (null smtpmail-recipient-address-list))
(if (not (smtpmail-via-smtp smtpmail-recipient-address-list
(current-buffer)))
(error "Sending failed; SMTP protocol error"))
(error "Sending failed; no recipients"))))
(delete-file file-msg)
(delete-file (concat file-msg ".el"))
(delete-region (point-at-bol) (point-at-bol 2)))
(write-region (point-min) (point-max) smtpmail-queue-index))))
;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
(defun smtpmail-fqdn ()
(if smtpmail-local-domain
(concat (system-name) "." smtpmail-local-domain)
(system-name)))
(defsubst smtpmail-cred-server (cred)
(nth 0 cred))
(defsubst smtpmail-cred-port (cred)
(nth 1 cred))
(defsubst smtpmail-cred-key (cred)
(nth 2 cred))
(defsubst smtpmail-cred-user (cred)
(nth 2 cred))
(defsubst smtpmail-cred-cert (cred)
(nth 3 cred))
(defsubst smtpmail-cred-passwd (cred)
(nth 3 cred))
(defun smtpmail-find-credentials (cred server port)
(catch 'done
(let ((l cred) el)
(while (setq el (pop l))
(when (and (equal server (smtpmail-cred-server el))
(equal port (smtpmail-cred-port el)))
(throw 'done el))))))
(defun smtpmail-maybe-append-domain (recipient)
(if (or (not smtpmail-sendto-domain)
(string-match "@" recipient))
recipient
(concat recipient "@" smtpmail-sendto-domain)))
(defun smtpmail-intersection (list1 list2)
(let ((result nil))
(dolist (el2 list2)
(when (memq el2 list1)
(push el2 result)))
(nreverse result)))
(defvar starttls-extra-args)
(defvar starttls-extra-arguments)
(defun smtpmail-open-stream (process-buffer host port)
(let ((cred (smtpmail-find-credentials
smtpmail-starttls-credentials host port)))
(if (null (and cred (condition-case ()
(with-no-warnings
(require 'starttls)
(call-process (if starttls-use-gnutls
starttls-gnutls-program
starttls-program)))
(error nil))))
;; The normal case.
(open-network-stream "SMTP" process-buffer host port)
(let* ((cred-key (smtpmail-cred-key cred))
(cred-cert (smtpmail-cred-cert cred))
(starttls-extra-args
(append
starttls-extra-args
(when (and (stringp cred-key) (stringp cred-cert)
(file-regular-p
(setq cred-key (expand-file-name cred-key)))
(file-regular-p
(setq cred-cert (expand-file-name cred-cert))))
(list "--key-file" cred-key "--cert-file" cred-cert))))
(starttls-extra-arguments
(append
starttls-extra-arguments
(when (and (stringp cred-key) (stringp cred-cert)
(file-regular-p
(setq cred-key (expand-file-name cred-key)))
(file-regular-p
(setq cred-cert (expand-file-name cred-cert))))
(list "--x509keyfile" cred-key "--x509certfile" cred-cert)))))
(starttls-open-stream "SMTP" process-buffer host port)))))
(defun smtpmail-try-auth-methods (process supported-extensions host port)
(let* ((mechs (cdr-safe (assoc 'auth supported-extensions)))
(mech (car (smtpmail-intersection smtpmail-auth-supported mechs)))
(cred (if (stringp smtpmail-auth-credentials)
(let* ((netrc (netrc-parse smtpmail-auth-credentials))
(port-name (format "%s" (or port "smtp")))
(hostentry (netrc-machine netrc host port-name
port-name)))
(when hostentry
(list host port
(netrc-get hostentry "login")
(netrc-get hostentry "password"))))
(smtpmail-find-credentials
smtpmail-auth-credentials host port)))
(passwd (when cred
(or (smtpmail-cred-passwd cred)
(read-passwd
(format "SMTP password for %s:%s: "
(smtpmail-cred-server cred)
(smtpmail-cred-port cred))))))
ret)
(when (and cred mech)
(cond
((eq mech 'cram-md5)
(smtpmail-send-command process (upcase (format "AUTH %s" mech)))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil))
(when (eq (car ret) 334)
(let* ((challenge (substring (cadr ret) 4))
(decoded (base64-decode-string challenge))
(hash (rfc2104-hash 'md5 64 16 passwd decoded))
(response (concat (smtpmail-cred-user cred) " " hash))
;; Osamu Yamane <yamane@green.ocn.ne.jp>:
;; SMTP auth fails because the SMTP server identifies
;; only the first part of the string (delimited by
;; new line characters) as a response from the
;; client, and the rest as distinct commands.
;; In my case, the response string is 80 characters
;; long. Without the no-line-break option for
;; base64-encode-sting, only the first 76 characters
;; are taken as a response to the server, and the
;; authentication fails.
(encoded (base64-encode-string response t)))
(smtpmail-send-command process (format "%s" encoded))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil)))))
((eq mech 'login)
(smtpmail-send-command process "AUTH LOGIN")
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil))
(smtpmail-send-command
process (base64-encode-string (smtpmail-cred-user cred) t))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil))
(smtpmail-send-command process (base64-encode-string passwd t))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(>= (car ret) 400))
(throw 'done nil)))
((eq mech 'plain)
;; We used to send an empty initial request, and wait for an
;; empty response, and then send the password, but this
;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this
;; is not sent if the server did not advertise AUTH PLAIN in
;; the EHLO response. See RFC 2554 for more info.
(smtpmail-send-command process
(concat "AUTH PLAIN "
(base64-encode-string
(concat "\0"
(smtpmail-cred-user cred)
"\0"
passwd) t)))
(if (or (null (car (setq ret (smtpmail-read-response process))))
(not (integerp (car ret)))
(not (equal (car ret) 235)))
(throw 'done nil)))
(t
(error "Mechanism %s not implemented" mech)))
;; Remember the password.
(when (and (not (stringp smtpmail-auth-credentials))
(null (smtpmail-cred-passwd cred)))
(setcar (cdr (cdr (cdr cred))) passwd)))))
(defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
(let ((process nil)
(host (or smtpmail-smtp-server
(error "`smtpmail-smtp-server' not defined")))
(port smtpmail-smtp-service)
;; smtpmail-mail-address should be set to the appropriate
;; buffer-local value by the caller, but in case not:
(envelope-from (or smtpmail-mail-address
(and mail-specify-envelope-from
(mail-envelope-from))
user-mail-address))
response-code
greeting
process-buffer
(supported-extensions '()))
(unwind-protect
(catch 'done
;; get or create the trace buffer
(setq process-buffer
(get-buffer-create (format "*trace of SMTP session to %s*" host)))
;; clear the trace buffer of old output
(with-current-buffer process-buffer
(setq buffer-undo-list t)
(erase-buffer))
;; open the connection to the server
(setq process (smtpmail-open-stream process-buffer host port))
(and (null process) (throw 'done nil))
;; set the send-filter
(set-process-filter process 'smtpmail-process-filter)
(with-current-buffer process-buffer
(set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)
(make-local-variable 'smtpmail-read-point)
(setq smtpmail-read-point (point-min))
(if (or (null (car (setq greeting (smtpmail-read-response process))))
(not (integerp (car greeting)))
(>= (car greeting) 400))
(throw 'done nil)
)
(let ((do-ehlo t)
(do-starttls t))
(while do-ehlo
;; EHLO
(smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn)))
(if (or (null (car (setq response-code
(smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(progn
;; HELO
(smtpmail-send-command
process (format "HELO %s" (smtpmail-fqdn)))
(if (or (null (car (setq response-code
(smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)))
(dolist (line (cdr (cdr response-code)))
(let ((name
(with-case-table ascii-case-table
(mapcar (lambda (s) (intern (downcase s)))
(split-string (substring line 4) "[ ]")))))
(and (eq (length name) 1)
(setq name (car name)))
(and name
(cond ((memq (if (consp name) (car name) name)
'(verb xvrb 8bitmime onex xone
expn size dsn etrn
enhancedstatuscodes
help xusr
auth=login auth starttls))
(setq supported-extensions
(cons name supported-extensions)))
(smtpmail-warn-about-unknown-extensions
(message "Unknown extension %s" name)))))))
(if (and do-starttls
(smtpmail-find-credentials smtpmail-starttls-credentials host port)
(member 'starttls supported-extensions)
(numberp (process-id process)))
(progn
(smtpmail-send-command process (format "STARTTLS"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))
(starttls-negotiate process)
(setq do-starttls nil))
(setq do-ehlo nil))))
(smtpmail-try-auth-methods process supported-extensions host port)
(if (or (member 'onex supported-extensions)
(member 'xone supported-extensions))
(progn
(smtpmail-send-command process (format "ONEX"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
(if (and smtpmail-debug-verb
(or (member 'verb supported-extensions)
(member 'xvrb supported-extensions)))
(progn
(smtpmail-send-command process (format "VERB"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
(if (member 'xusr supported-extensions)
(progn
(smtpmail-send-command process (format "XUSR"))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil))))
;; MAIL FROM:<sender>
(let ((size-part
(if (or (member 'size supported-extensions)
(assoc 'size supported-extensions))
(format " SIZE=%d"
(with-current-buffer smtpmail-text-buffer
;; size estimate:
(+ (- (point-max) (point-min))
;; Add one byte for each change-of-line
;; because of CR-LF representation:
(count-lines (point-min) (point-max)))))
""))
(body-part
(if (member '8bitmime supported-extensions)
;; FIXME:
;; Code should be added here that transforms
;; the contents of the message buffer into
;; something the receiving SMTP can handle.
;; For a receiver that supports 8BITMIME, this
;; may mean converting BINARY to BASE64, or
;; adding Content-Transfer-Encoding and the
;; other MIME headers. The code should also
;; return an indication of what encoding the
;; message buffer is now, i.e. ASCII or
;; 8BITMIME.
(if nil
" BODY=8BITMIME"
"")
"")))
; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
(smtpmail-send-command process (format "MAIL FROM:<%s>%s%s"
envelope-from
size-part
body-part))
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)
))
;; RCPT TO:<recipient>
(let ((n 0))
(while (not (null (nth n recipient)))
(smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient))))
(setq n (1+ n))
(setq response-code (smtpmail-read-response process))
(if (or (null (car response-code))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)
)
))
;; DATA
(smtpmail-send-command process "DATA")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)
)
;; Mail contents
(smtpmail-send-data process smtpmail-text-buffer)
;;DATA end "."
(smtpmail-send-command process ".")
(if (or (null (car (setq response-code (smtpmail-read-response process))))
(not (integerp (car response-code)))
(>= (car response-code) 400))
(throw 'done nil)
)
;;QUIT
; (smtpmail-send-command process "QUIT")
; (and (null (car (smtpmail-read-response process)))
; (throw 'done nil))
t ))
(if process
(with-current-buffer (process-buffer process)
(smtpmail-send-command process "QUIT")
(smtpmail-read-response process)
; (if (or (null (car (setq response-code (smtpmail-read-response process))))
; (not (integerp (car response-code)))
; (>= (car response-code) 400))
; (throw 'done nil)
; )
(delete-process process)
(unless smtpmail-debug-info
(kill-buffer process-buffer)))))))
(defun smtpmail-process-filter (process output)
(with-current-buffer (process-buffer process)
(goto-char (point-max))
(insert output)))
(defun smtpmail-read-response (process)
(let ((case-fold-search nil)
(response-strings nil)
(response-continue t)
(return-value '(nil ()))
match-end)
(catch 'done
(while response-continue
(goto-char smtpmail-read-point)
(while (not (search-forward "\r\n" nil t))
(unless (memq (process-status process) '(open run))
(throw 'done nil))
(accept-process-output process)
(goto-char smtpmail-read-point))
(setq match-end (point))
(setq response-strings
(cons (buffer-substring smtpmail-read-point (- match-end 2))
response-strings))
(goto-char smtpmail-read-point)
(if (looking-at "[0-9]+ ")
(let ((begin (match-beginning 0))
(end (match-end 0)))
(if smtpmail-debug-info
(message "%s" (car response-strings)))
(setq smtpmail-read-point match-end)
;; ignore lines that start with "0"
(if (looking-at "0[0-9]+ ")
nil
(setq response-continue nil)
(setq return-value
(cons (string-to-number
(buffer-substring begin end))
(nreverse response-strings)))))
(if (looking-at "[0-9]+-")
(progn (if smtpmail-debug-info
(message "%s" (car response-strings)))
(setq smtpmail-read-point match-end)
(setq response-continue t))
(progn
(setq smtpmail-read-point match-end)
(setq response-continue nil)
(setq return-value
(cons nil (nreverse response-strings)))))))
(setq smtpmail-read-point match-end))
return-value))
(defun smtpmail-send-command (process command)
(goto-char (point-max))
(if (= (aref command 0) ?P)
(insert "PASS <omitted>\r\n")
(insert command "\r\n"))
(setq smtpmail-read-point (point))
(process-send-string process command)
(process-send-string process "\r\n"))
(defun smtpmail-send-data-1 (process data)
(goto-char (point-max))
(if (and (multibyte-string-p data)
smtpmail-code-conv-from)
(setq data (string-as-multibyte
(encode-coding-string data smtpmail-code-conv-from))))
(if smtpmail-debug-info
(insert data "\r\n"))
(setq smtpmail-read-point (point))
;; Escape "." at start of a line
(if (eq (string-to-char data) ?.)
(process-send-string process "."))
(process-send-string process data)
(process-send-string process "\r\n")
)
(defun smtpmail-send-data (process buffer)
(let ((data-continue t) sending-data)
(with-current-buffer buffer
(goto-char (point-min)))
(while data-continue
(with-current-buffer buffer
(setq sending-data (buffer-substring (point-at-bol) (point-at-eol)))
(end-of-line 2)
(setq data-continue (not (eobp))))
(smtpmail-send-data-1 process sending-data))))
(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO: <address>."
(unwind-protect
(with-current-buffer smtpmail-address-buffer
(erase-buffer)
(let
((case-fold-search t)
(simple-address-list "")
this-line
this-line-end
addr-regexp)
(insert-buffer-substring smtpmail-text-buffer header-start header-end)
(goto-char (point-min))
;; RESENT-* fields should stop processing of regular fields.
(save-excursion
(setq addr-regexp
(if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):"
header-end t)
"^Resent-\\(to\\|cc\\|bcc\\):"
"^\\(To:\\|Cc:\\|Bcc:\\)")))
(while (re-search-forward addr-regexp header-end t)
(replace-match "")
(setq this-line (match-beginning 0))
(forward-line 1)
;; get any continuation lines
(while (and (looking-at "^[ \t]+") (< (point) header-end))
(forward-line 1))
(setq this-line-end (point-marker))
(setq simple-address-list
(concat simple-address-list " "
(mail-strip-quoted-names (buffer-substring this-line this-line-end))))
)
(erase-buffer)
(insert " " simple-address-list "\n")
(subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank
(subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank
(subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank
(goto-char (point-min))
;; tidyness in case hook is not robust when it looks at this
(while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
(goto-char (point-min))
(let (recipient-address-list)
(while (re-search-forward " \\([^ ]+\\) " (point-max) t)
(backward-char 1)
(setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
recipient-address-list))
)
(setq smtpmail-recipient-address-list recipient-address-list))
)
)
)
)
(defun smtpmail-do-bcc (header-end)
"Delete [Resent-]BCC: and their continuation lines from the header area.
There may be multiple BCC: lines, and each may have arbitrarily
many continuation lines."
(let ((case-fold-search t))
(save-excursion
(goto-char (point-min))
;; iterate over all BCC: lines
(while (re-search-forward "^\\(RESENT-\\)?BCC:" header-end t)
(delete-region (match-beginning 0)
(progn (forward-line 1) (point)))
;; get rid of any continuation lines
(while (and (looking-at "^[ \t].*\n") (< (point) header-end))
(replace-match ""))))))
(provide 'smtpmail)
;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466
;;; smtpmail.el ends here
author | Bastien Guerry <bzg@altern.org> |
---|---|
date | Wed, 13 Feb 2008 20:58:26 +0000 |
parents | 73661ddc7ac7 |
children | 606f2d163a64 014868cc0301 |
rev | line source |
---|---|
13337 | 1 ;;; jka-compr.el --- reading/writing/loading compressed files |
2 | |
74442 | 3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2001, 2002, 2003, |
79721 | 4 ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
6002 | 5 |
6 ;; Author: jka@ece.cmu.edu (Jay K. Adams) | |
17976 | 7 ;; Maintainer: FSF |
6002 | 8 ;; Keywords: data |
9 | |
13514
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
10 ;; This file is part of GNU Emacs. |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
11 |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
13 ;; it under the terms of the GNU General Public License as published by |
78236
9355f9b7bbff
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
75494
diff
changeset
|
14 ;; the Free Software Foundation; either version 3, or (at your option) |
13514
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
15 ;; any later version. |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
16 |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
17 ;; GNU Emacs is distributed in the hope that it will be useful, |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
20 ;; GNU General Public License for more details. |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
21 |
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
22 ;; You should have received a copy of the GNU General Public License |
14169 | 23 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
64091 | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02110-1301, USA. | |
13514
0e46e8075a1d
(auto-compression-mode): Make arg optional.
Richard M. Stallman <rms@gnu.org>
parents:
13337
diff
changeset
|
26 |
38412
253f761ad37b
Some fixes to follow coding conventions in files maintained by FSF.
Pavel Janík <Pavel@Janik.cz>
parents:
34732
diff
changeset
|
27 ;;; Commentary: |
6002 | 28 |
14169 | 29 ;; This package implements low-level support for reading, writing, |
30 ;; and loading compressed files. It hooks into the low-level file | |
31 ;; I/O functions (including write-region and insert-file-contents) so | |
32 ;; that they automatically compress or uncompress a file if the file | |
33 ;; appears to need it (based on the extension of the file name). | |
34 ;; Packages like Rmail, VM, GNUS, and Info should be able to work | |
35 ;; with compressed files without modification. | |
6002 | 36 |
37 | |
14169 | 38 ;; INSTRUCTIONS: |
39 ;; | |
32497 | 40 ;; To use jka-compr, invoke the command `auto-compression-mode' (which |
41 ;; see), or customize the variable of the same name. Its operation | |
42 ;; should be transparent to the user (except for messages appearing when | |
43 ;; a file is being compressed or uncompressed). | |
14169 | 44 ;; |
45 ;; The variable, jka-compr-compression-info-list can be used to | |
46 ;; customize jka-compr to work with other compression programs. | |
47 ;; The default value of this variable allows jka-compr to work with | |
48 ;; Unix compress and gzip. | |
49 ;; | |
50 ;; If you don't want messages about compressing and decompressing | |
75423
d03ddfe8401e
(jka-compr-shell): Doc fix.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
51 ;; to show up in the echo area, you can set the compress-msg and |
d03ddfe8401e
(jka-compr-shell): Doc fix.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
52 ;; decompress-msg fields of the jka-compr-compression-info-list to |
14169 | 53 ;; nil. |
6002 | 54 |
55 | |
14169 | 56 ;; APPLICATION NOTES: |
57 ;; | |
58 ;; crypt++ | |
45720 | 59 ;; jka-compr can coexist with crypt++ if you take all the decompression |
14169 | 60 ;; entries out of the crypt-encoding-list. Clearly problems will arise if |
61 ;; you have two programs trying to compress/decompress files. jka-compr | |
62 ;; will not "work with" crypt++ in the following sense: you won't be able to | |
63 ;; decode encrypted compressed files--that is, files that have been | |
64 ;; compressed then encrypted (in that order). Theoretically, crypt++ and | |
65 ;; jka-compr could properly handle a file that has been encrypted then | |
66 ;; compressed, but there is little point in trying to compress an encrypted | |
67 ;; file. | |
68 ;; | |
6002 | 69 |
70 | |
14169 | 71 ;; ACKNOWLEDGMENTS |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
72 ;; |
14169 | 73 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
74 ;; have made helpful suggestions, reported bugs, and even fixed bugs in |
14169 | 75 ;; jka-compr. I recall the following people as being particularly helpful. |
76 ;; | |
77 ;; Jean-loup Gailly | |
78 ;; David Hughes | |
79 ;; Richard Pieri | |
80 ;; Daniel Quinlan | |
81 ;; Chris P. Ross | |
82 ;; Rick Sladkey | |
83 ;; | |
84 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for | |
85 ;; Version 18 of Emacs. | |
86 ;; | |
87 ;; After I had made progress on the original jka-compr for V18, I learned of a | |
88 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly | |
89 ;; what I was trying to do. I looked over the jam-zcat source code and | |
90 ;; probably got some ideas from it. | |
91 ;; | |
6002 | 92 |
93 ;;; Code: | |
94 | |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
95 (require 'jka-cmpr-hook) |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
96 |
17411
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
97 (defcustom jka-compr-shell "sh" |
6002 | 98 "*Shell to be used for calling compression programs. |
75423
d03ddfe8401e
(jka-compr-shell): Doc fix.
Juanma Barranquero <lekktu@gmail.com>
parents:
75347
diff
changeset
|
99 NOTE: Not used in MS-DOS and Windows systems." |
17411
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
100 :type 'string |
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
101 :group 'jka-compr) |
6002 | 102 |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
103 (defvar jka-compr-use-shell |
21633
185e8e424ee9
(jka-compr-use-shell) [ms-dos, windows-nt]: Do not use a shell.
Richard M. Stallman <rms@gnu.org>
parents:
20893
diff
changeset
|
104 (not (memq system-type '(ms-dos windows-nt)))) |
6002 | 105 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
106 (defvar jka-compr-really-do-compress nil |
60781
4dec7a239cfa
(jka-compr-really-do-compress): Make variable buffer-local.
Richard M. Stallman <rms@gnu.org>
parents:
54521
diff
changeset
|
107 "Non-nil in a buffer whose visited file was uncompressed on visiting it. |
4dec7a239cfa
(jka-compr-really-do-compress): Make variable buffer-local.
Richard M. Stallman <rms@gnu.org>
parents:
54521
diff
changeset
|
108 This means compress the data on writing the file, even if the |
4dec7a239cfa
(jka-compr-really-do-compress): Make variable buffer-local.
Richard M. Stallman <rms@gnu.org>
parents:
54521
diff
changeset
|
109 data appears to be compressed already.") |
4dec7a239cfa
(jka-compr-really-do-compress): Make variable buffer-local.
Richard M. Stallman <rms@gnu.org>
parents:
54521
diff
changeset
|
110 (make-variable-buffer-local 'jka-compr-really-do-compress) |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
111 (put 'jka-compr-really-do-compress 'permanent-local t) |
7617
edc853e14f7b
(jka-compr-op-table, jka-compr-file-name-handler-entry): Move defvars.
Richard M. Stallman <rms@gnu.org>
parents:
7616
diff
changeset
|
112 |
6002 | 113 |
114 (put 'compression-error 'error-conditions '(compression-error file-error error)) | |
115 | |
116 | |
11635
b56f6afa16ec
(jka-compr-write-region): Handle the append
Richard M. Stallman <rms@gnu.org>
parents:
11621
diff
changeset
|
117 (defvar jka-compr-acceptable-retval-list '(0 2 141)) |
6002 | 118 |
119 | |
120 (defun jka-compr-error (prog args infile message &optional errfile) | |
121 | |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
122 (let ((errbuf (get-buffer-create " *jka-compr-error*"))) |
16940
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
123 (with-current-buffer errbuf |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
124 (widen) (erase-buffer) |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
125 (insert (format "Error while executing \"%s %s < %s\"\n\n" |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
126 prog |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
127 (mapconcat 'identity args " ") |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
128 infile)) |
6002 | 129 |
16940
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
130 (and errfile |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
131 (insert-file-contents errfile))) |
6002 | 132 (display-buffer errbuf)) |
133 | |
16940
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
134 (signal 'compression-error |
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
135 (list "Opening input file" (format "error %s" message) infile))) |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
136 |
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
137 |
40782
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
138 (defcustom jka-compr-dd-program "/bin/dd" |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
139 "How to invoke `dd'." |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
140 :type 'string |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
141 :group 'jka-compr) |
6002 | 142 |
143 | |
6041
649926e9c1a8
(jka-compr-partial-uncompress): Make dd give you
Richard M. Stallman <rms@gnu.org>
parents:
6002
diff
changeset
|
144 (defvar jka-compr-dd-blocksize 256) |
6002 | 145 |
146 | |
147 (defun jka-compr-partial-uncompress (prog message args infile beg len) | |
148 "Call program PROG with ARGS args taking input from INFILE. | |
149 Fourth and fifth args, BEG and LEN, specify which part of the output | |
8065
31eb7a0e2763
(jka-compr-partial-uncompress): Handle the case where
Richard M. Stallman <rms@gnu.org>
parents:
7976
diff
changeset
|
150 to keep: LEN chars starting BEG chars from the beginning." |
40782
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
151 (let ((start (point)) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
152 (prefix beg)) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
153 (if (and jka-compr-use-shell jka-compr-dd-program) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
154 ;; Put the uncompression output through dd |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
155 ;; to discard the part we don't want. |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
156 (let ((skip (/ beg jka-compr-dd-blocksize)) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
157 (err-file (jka-compr-make-temp-name)) |
75494
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
158 ;; call-process barfs if default-directory is inaccessible. |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
159 (default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
160 (if (and default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
161 (file-accessible-directory-p default-directory)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
162 default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
163 (file-name-directory infile))) |
40782
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
164 count) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
165 ;; Update PREFIX based on the text that we won't read in. |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
166 (setq prefix (- beg (* skip jka-compr-dd-blocksize)) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
167 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize)))) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
168 (unwind-protect |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
169 (or (memq (call-process |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
170 jka-compr-shell infile t nil "-c" |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
171 (format |
42231
054cf5ce349b
(jka-compr-partial-uncompress): Use null-device instead of a literal
Eli Zaretskii <eliz@gnu.org>
parents:
41102
diff
changeset
|
172 "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s" |
40782
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
173 prog |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
174 (mapconcat 'identity args " ") |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
175 err-file |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
176 jka-compr-dd-program |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
177 jka-compr-dd-blocksize |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
178 skip |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
179 ;; dd seems to be unreliable about |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
180 ;; providing the last block. So, always |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
181 ;; read one more than you think you need. |
42231
054cf5ce349b
(jka-compr-partial-uncompress): Use null-device instead of a literal
Eli Zaretskii <eliz@gnu.org>
parents:
41102
diff
changeset
|
182 (if count (format "count=%d" (1+ count)) "") |
054cf5ce349b
(jka-compr-partial-uncompress): Use null-device instead of a literal
Eli Zaretskii <eliz@gnu.org>
parents:
41102
diff
changeset
|
183 null-device)) |
40782
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
184 jka-compr-acceptable-retval-list) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
185 (jka-compr-error prog args infile message err-file)) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
186 (jka-compr-delete-temp-file err-file))) |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
187 ;; Run the uncompression program directly. |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
188 ;; We get the whole file and must delete what we don't want. |
3a4d800ced48
(jka-compr-partial-uncompress): Support an alternative of not using dd.
Richard M. Stallman <rms@gnu.org>
parents:
39829
diff
changeset
|
189 (jka-compr-call-process prog message infile t nil args)) |
6002 | 190 |
8065
31eb7a0e2763
(jka-compr-partial-uncompress): Handle the case where
Richard M. Stallman <rms@gnu.org>
parents:
7976
diff
changeset
|
191 ;; Delete the stuff after what we want, if there is any. |
6002 | 192 (and |
6041
649926e9c1a8
(jka-compr-partial-uncompress): Make dd give you
Richard M. Stallman <rms@gnu.org>
parents:
6002
diff
changeset
|
193 len |
8065
31eb7a0e2763
(jka-compr-partial-uncompress): Handle the case where
Richard M. Stallman <rms@gnu.org>
parents:
7976
diff
changeset
|
194 (< (+ start prefix len) (point)) |
6041
649926e9c1a8
(jka-compr-partial-uncompress): Make dd give you
Richard M. Stallman <rms@gnu.org>
parents:
6002
diff
changeset
|
195 (delete-region (+ start prefix len) (point))) |
6002 | 196 |
8065
31eb7a0e2763
(jka-compr-partial-uncompress): Handle the case where
Richard M. Stallman <rms@gnu.org>
parents:
7976
diff
changeset
|
197 ;; Delete the stuff before what we want. |
6002 | 198 (delete-region start (+ start prefix)))) |
199 | |
200 | |
201 (defun jka-compr-call-process (prog message infile output temp args) | |
75494
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
202 ;; call-process barfs if default-directory is inaccessible. |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
203 (let ((default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
204 (if (and default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
205 (file-accessible-directory-p default-directory)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
206 default-directory |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
207 (file-name-directory infile)))) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
208 (if jka-compr-use-shell |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
209 (let ((err-file (jka-compr-make-temp-name)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
210 (coding-system-for-read (or coding-system-for-read 'undecided)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
211 (coding-system-for-write 'no-conversion)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
212 (unwind-protect |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
213 (or (memq |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
214 (call-process jka-compr-shell infile |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
215 (if (stringp output) nil output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
216 nil |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
217 "-c" |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
218 (format "%s %s 2> %s %s" |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
219 prog |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
220 (mapconcat 'identity args " ") |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
221 err-file |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
222 (if (stringp output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
223 (concat "> " output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
224 ""))) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
225 jka-compr-acceptable-retval-list) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
226 (jka-compr-error prog args infile message err-file)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
227 (jka-compr-delete-temp-file err-file))) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
228 (or (eq 0 |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
229 (apply 'call-process |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
230 prog infile (if (stringp output) temp output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
231 nil args)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
232 (jka-compr-error prog args infile message)) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
233 (and (stringp output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
234 (with-current-buffer temp |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
235 (write-region (point-min) (point-max) output) |
04d75deb3a31
(jka-compr-partial-uncompress, jka-compr-call-process): Rebind
Chong Yidong <cyd@stupidchicken.com>
parents:
75423
diff
changeset
|
236 (erase-buffer)))))) |
6002 | 237 |
238 | |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
239 ;; Support for temp files. Much of this was inspired if not lifted |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
240 ;; from ange-ftp. |
6002 | 241 |
17411
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
242 (defcustom jka-compr-temp-name-template |
22100
eb3f36cc775f
(jka-compr-temp-name-template): Use temporary-file-directory.
Richard M. Stallman <rms@gnu.org>
parents:
22090
diff
changeset
|
243 (expand-file-name "jka-com" temporary-file-directory) |
17441
41a10d128e3b
(jka-compr-temp-name-template): Fix editing error.
Richard M. Stallman <rms@gnu.org>
parents:
17411
diff
changeset
|
244 "Prefix added to all temp files created by jka-compr. |
17411
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
245 There should be no more than seven characters after the final `/'." |
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
246 :type 'string |
f0ff96a35eb8
Add defgroup's; use defcustom for user vars.
Richard M. Stallman <rms@gnu.org>
parents:
16940
diff
changeset
|
247 :group 'jka-compr) |
6002 | 248 |
249 (defun jka-compr-make-temp-name (&optional local-copy) | |
250 "This routine will return the name of a new file." | |
26039
fb6b9c37cdc4
Use make-temp-file.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
25285
diff
changeset
|
251 (make-temp-file jka-compr-temp-name-template)) |
6002 | 252 |
26039
fb6b9c37cdc4
Use make-temp-file.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
25285
diff
changeset
|
253 (defalias 'jka-compr-delete-temp-file 'delete-file) |
6002 | 254 |
255 | |
256 (defun jka-compr-write-region (start end file &optional append visit) | |
257 (let* ((filename (expand-file-name file)) | |
258 (visit-file (if (stringp visit) (expand-file-name visit) filename)) | |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
259 (info (jka-compr-get-compression-info visit-file)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
260 (magic (and info (jka-compr-info-file-magic-bytes info)))) |
6002 | 261 |
42461
c28b5df30ea0
(jka-compr-write-region): If START = nil, use whole buf.
Richard M. Stallman <rms@gnu.org>
parents:
42231
diff
changeset
|
262 ;; If START is nil, use the whole buffer. |
c28b5df30ea0
(jka-compr-write-region): If START = nil, use whole buf.
Richard M. Stallman <rms@gnu.org>
parents:
42231
diff
changeset
|
263 (if (null start) |
c28b5df30ea0
(jka-compr-write-region): If START = nil, use whole buf.
Richard M. Stallman <rms@gnu.org>
parents:
42231
diff
changeset
|
264 (setq start 1 end (1+ (buffer-size)))) |
c28b5df30ea0
(jka-compr-write-region): If START = nil, use whole buf.
Richard M. Stallman <rms@gnu.org>
parents:
42231
diff
changeset
|
265 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
266 ;; If we uncompressed this file when visiting it, |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
267 ;; then recompress it when writing it |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
268 ;; even if the contents look compressed already. |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
269 (if (and jka-compr-really-do-compress |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
270 (eq start 1) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
271 (eq end (1+ (buffer-size)))) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
272 (setq magic nil)) |
6002 | 273 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
274 (if (and info |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
275 ;; If the contents to be written out |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
276 ;; are properly compressed already, |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
277 ;; don't try to compress them over again. |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
278 (not (and magic |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
279 (equal (if (stringp start) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
280 (substring start 0 (min (length start) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
281 (length magic))) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
282 (buffer-substring start |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
283 (min end |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
284 (+ start (length magic))))) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
285 magic)))) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
286 (let ((can-append (jka-compr-info-can-append info)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
287 (compress-program (jka-compr-info-compress-program info)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
288 (compress-message (jka-compr-info-compress-message info)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
289 (compress-args (jka-compr-info-compress-args info)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
290 (base-name (file-name-nondirectory visit-file)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
291 temp-file temp-buffer |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
292 ;; we need to leave `last-coding-system-used' set to its |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
293 ;; value after calling write-region the first time, so |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
294 ;; that `basic-save-buffer' sees the right value. |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
295 (coding-system-used last-coding-system-used)) |
6002 | 296 |
54521
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
297 (or compress-program |
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
298 (error "No compression program defined")) |
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
299 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
300 (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
301 (with-current-buffer temp-buffer |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
302 (widen) (erase-buffer)) |
6002 | 303 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
304 (if (and append |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
305 (not can-append) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
306 (file-exists-p filename)) |
6002 | 307 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
308 (let* ((local-copy (file-local-copy filename)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
309 (local-file (or local-copy filename))) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
310 |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
311 (setq temp-file local-file)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
312 |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
313 (setq temp-file (jka-compr-make-temp-name))) |
6002 | 314 |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
315 (and |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
316 compress-message |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
317 (message "%s %s..." compress-message base-name)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
318 |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
319 (jka-compr-run-real-handler 'write-region |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
320 (list start end temp-file t 'dont)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
321 ;; save value used by the real write-region |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
322 (setq coding-system-used last-coding-system-used) |
6002 | 323 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
324 ;; Here we must read the output of compress program as is |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
325 ;; without any code conversion. |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
326 (let ((coding-system-for-read 'no-conversion)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
327 (jka-compr-call-process compress-program |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
328 (concat compress-message |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
329 " " base-name) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
330 temp-file |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
331 temp-buffer |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
332 nil |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
333 compress-args)) |
6002 | 334 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
335 (with-current-buffer temp-buffer |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
336 (let ((coding-system-for-write 'no-conversion)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
337 (if (memq system-type '(ms-dos windows-nt)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
338 (setq buffer-file-type t) ) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
339 (jka-compr-run-real-handler 'write-region |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
340 (list (point-min) (point-max) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
341 filename |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
342 (and append can-append) 'dont)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
343 (erase-buffer)) ) |
6002 | 344 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
345 (jka-compr-delete-temp-file temp-file) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
346 |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
347 (and |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
348 compress-message |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
349 (message "%s %s...done" compress-message base-name)) |
6002 | 350 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
351 (cond |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
352 ((eq visit t) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
353 (setq buffer-file-name filename) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
354 (setq jka-compr-really-do-compress t) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
355 (set-visited-file-modtime)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
356 ((stringp visit) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
357 (setq buffer-file-name visit) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
358 (let ((buffer-file-name filename)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
359 (set-visited-file-modtime)))) |
6002 | 360 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
361 (and (or (eq visit t) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
362 (eq visit nil) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
363 (stringp visit)) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
364 (message "Wrote %s" visit-file)) |
22360
09dbe38a603f
(jka-compr-write-region): Ensure
Karl Heuer <kwzh@gnu.org>
parents:
22194
diff
changeset
|
365 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
366 ;; ensure `last-coding-system-used' has an appropriate value |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
367 (setq last-coding-system-used coding-system-used) |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
368 |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
369 nil) |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
370 |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
371 (jka-compr-run-real-handler 'write-region |
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
372 (list start end filename append visit))))) |
6002 | 373 |
374 | |
6218
f4d5338c2142
(jka-compr-insert-file-contents): Handle 5th arg.
Richard M. Stallman <rms@gnu.org>
parents:
6041
diff
changeset
|
375 (defun jka-compr-insert-file-contents (file &optional visit beg end replace) |
6002 | 376 (barf-if-buffer-read-only) |
377 | |
378 (and (or beg end) | |
379 visit | |
380 (error "Attempt to visit less than an entire file")) | |
381 | |
382 (let* ((filename (expand-file-name file)) | |
383 (info (jka-compr-get-compression-info filename))) | |
384 | |
385 (if info | |
386 | |
387 (let ((uncompress-message (jka-compr-info-uncompress-message info)) | |
388 (uncompress-program (jka-compr-info-uncompress-program info)) | |
389 (uncompress-args (jka-compr-info-uncompress-args info)) | |
390 (base-name (file-name-nondirectory filename)) | |
391 (notfound nil) | |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
392 (local-copy |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
393 (jka-compr-run-real-handler 'file-local-copy (list filename))) |
6002 | 394 local-file |
49377
e5099d153f94
(jka-compr-insert-file-contents): Read a process
Kenichi Handa <handa@m17n.org>
parents:
47180
diff
changeset
|
395 size start) |
6002 | 396 |
397 (setq local-file (or local-copy filename)) | |
398 | |
399 (and | |
400 visit | |
401 (setq buffer-file-name filename)) | |
402 | |
403 (unwind-protect ; to make sure local-copy gets deleted | |
404 | |
405 (progn | |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
406 |
6002 | 407 (and |
408 uncompress-message | |
409 (message "%s %s..." uncompress-message base-name)) | |
410 | |
411 (condition-case error-code | |
412 | |
49377
e5099d153f94
(jka-compr-insert-file-contents): Read a process
Kenichi Handa <handa@m17n.org>
parents:
47180
diff
changeset
|
413 (let ((coding-system-for-read 'no-conversion)) |
8774
ade4b542a74c
(jka-compr-compression-info-list): Expand regular
Richard M. Stallman <rms@gnu.org>
parents:
8593
diff
changeset
|
414 (if replace |
ade4b542a74c
(jka-compr-compression-info-list): Expand regular
Richard M. Stallman <rms@gnu.org>
parents:
8593
diff
changeset
|
415 (goto-char (point-min))) |
6002 | 416 (setq start (point)) |
417 (if (or beg end) | |
418 (jka-compr-partial-uncompress uncompress-program | |
419 (concat uncompress-message | |
420 " " base-name) | |
421 uncompress-args | |
422 local-file | |
423 (or beg 0) | |
424 (if (and beg end) | |
425 (- end beg) | |
426 end)) | |
11621
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
427 ;; If visiting, bind off buffer-file-name so that |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
428 ;; file-locking will not ask whether we should |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
429 ;; really edit the buffer. |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
430 (let ((buffer-file-name |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
431 (if visit nil buffer-file-name))) |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
432 (jka-compr-call-process uncompress-program |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
433 (concat uncompress-message |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
434 " " base-name) |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
435 local-file |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
436 t |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
437 nil |
710b5ce824c2
(jka-compr-insert-file-contents): When visiting,
Richard M. Stallman <rms@gnu.org>
parents:
11296
diff
changeset
|
438 uncompress-args))) |
6002 | 439 (setq size (- (point) start)) |
8774
ade4b542a74c
(jka-compr-compression-info-list): Expand regular
Richard M. Stallman <rms@gnu.org>
parents:
8593
diff
changeset
|
440 (if replace |
51284
55a88703765d
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
49597
diff
changeset
|
441 (delete-region (point) (point-max))) |
8774
ade4b542a74c
(jka-compr-compression-info-list): Expand regular
Richard M. Stallman <rms@gnu.org>
parents:
8593
diff
changeset
|
442 (goto-char start)) |
6002 | 443 (error |
63766
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
444 ;; If the file we wanted to uncompress does not exist, |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
445 ;; handle that according to VISIT as `insert-file-contents' |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
446 ;; would, maybe signaling the same error it normally would. |
6002 | 447 (if (and (eq (car error-code) 'file-error) |
448 (eq (nth 3 error-code) local-file)) | |
449 (if visit | |
450 (setq notfound error-code) | |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
451 (signal 'file-error |
6002 | 452 (cons "Opening input file" |
453 (nthcdr 2 error-code)))) | |
63766
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
454 ;; If the uncompression program can't be found, |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
455 ;; signal that as a non-file error |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
456 ;; so that find-file-noselect-1 won't handle it. |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
457 (if (and (eq (car error-code) 'file-error) |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
458 (equal (cadr error-code) "Searching for program")) |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
459 (error "Uncompression program `%s' not found" |
e6ea4d9f64f3
(jka-compr-insert-file-contents):
Richard M. Stallman <rms@gnu.org>
parents:
62108
diff
changeset
|
460 (nth 3 error-code))) |
6002 | 461 (signal (car error-code) (cdr error-code)))))) |
462 | |
463 (and | |
464 local-copy | |
465 (file-exists-p local-copy) | |
466 (delete-file local-copy))) | |
467 | |
53304
b9463f85fb04
(jka-compr-insert-file-contents): Avoid error when
Andreas Schwab <schwab@suse.de>
parents:
52401
diff
changeset
|
468 (unless notfound |
b9463f85fb04
(jka-compr-insert-file-contents): Avoid error when
Andreas Schwab <schwab@suse.de>
parents:
52401
diff
changeset
|
469 (decode-coding-inserted-region |
b9463f85fb04
(jka-compr-insert-file-contents): Avoid error when
Andreas Schwab <schwab@suse.de>
parents:
52401
diff
changeset
|
470 (point) (+ (point) size) |
b9463f85fb04
(jka-compr-insert-file-contents): Avoid error when
Andreas Schwab <schwab@suse.de>
parents:
52401
diff
changeset
|
471 (jka-compr-byte-compiler-base-file-name file) |
b9463f85fb04
(jka-compr-insert-file-contents): Avoid error when
Andreas Schwab <schwab@suse.de>
parents:
52401
diff
changeset
|
472 visit beg end replace)) |
49377
e5099d153f94
(jka-compr-insert-file-contents): Read a process
Kenichi Handa <handa@m17n.org>
parents:
47180
diff
changeset
|
473 |
6002 | 474 (and |
475 visit | |
476 (progn | |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
477 (unlock-buffer) |
6002 | 478 (setq buffer-file-name filename) |
26987
af30e0897839
(jka-compr-info-file-magic-bytes): New function.
Richard M. Stallman <rms@gnu.org>
parents:
26039
diff
changeset
|
479 (setq jka-compr-really-do-compress t) |
6002 | 480 (set-visited-file-modtime))) |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
481 |
6002 | 482 (and |
483 uncompress-message | |
484 (message "%s %s...done" uncompress-message base-name)) | |
485 | |
486 (and | |
487 visit | |
488 notfound | |
489 (signal 'file-error | |
490 (cons "Opening input file" (nth 2 notfound)))) | |
491 | |
22484
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
492 ;; This is done in insert-file-contents after we return. |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
493 ;; That is a little weird, but better to go along with it now |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
494 ;; than to change it now. |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
495 |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
496 ;;; ;; Run the functions that insert-file-contents would. |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
497 ;;; (let ((p after-insert-file-functions) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
498 ;;; (insval size)) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
499 ;;; (while p |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
500 ;;; (setq insval (funcall (car p) size)) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
501 ;;; (if insval |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
502 ;;; (progn |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
503 ;;; (or (integerp insval) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
504 ;;; (signal 'wrong-type-argument |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
505 ;;; (list 'integerp insval))) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
506 ;;; (setq size insval))) |
661650f543ee
(jka-compr-insert-file-contents): Don't run
Richard M. Stallman <rms@gnu.org>
parents:
22360
diff
changeset
|
507 ;;; (setq p (cdr p)))) |
8774
ade4b542a74c
(jka-compr-compression-info-list): Expand regular
Richard M. Stallman <rms@gnu.org>
parents:
8593
diff
changeset
|
508 |
54521
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
509 (or (jka-compr-info-compress-program info) |
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
510 (message "You can't save this buffer because compression program is not defined")) |
36922d8fd700
(jka-compr-compression-info-list): Add tbz and dz.
Juri Linkov <juri@jurta.org>
parents:
53477
diff
changeset
|
511 |
6002 | 512 (list filename size)) |
513 | |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
514 (jka-compr-run-real-handler 'insert-file-contents |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
515 (list file visit beg end replace))))) |
6002 | 516 |
517 | |
518 (defun jka-compr-file-local-copy (file) | |
519 (let* ((filename (expand-file-name file)) | |
520 (info (jka-compr-get-compression-info filename))) | |
521 | |
522 (if info | |
523 | |
524 (let ((uncompress-message (jka-compr-info-uncompress-message info)) | |
525 (uncompress-program (jka-compr-info-uncompress-program info)) | |
526 (uncompress-args (jka-compr-info-uncompress-args info)) | |
527 (base-name (file-name-nondirectory filename)) | |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
528 (local-copy |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
529 (jka-compr-run-real-handler 'file-local-copy (list filename))) |
6002 | 530 (temp-file (jka-compr-make-temp-name t)) |
11635
b56f6afa16ec
(jka-compr-write-region): Handle the append
Richard M. Stallman <rms@gnu.org>
parents:
11621
diff
changeset
|
531 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*")) |
6002 | 532 local-file) |
533 | |
534 (setq local-file (or local-copy filename)) | |
535 | |
536 (unwind-protect | |
537 | |
16940
6d680b18a47b
(jka-compr-error): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
16630
diff
changeset
|
538 (with-current-buffer temp-buffer |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
539 |
6002 | 540 (and |
541 uncompress-message | |
542 (message "%s %s..." uncompress-message base-name)) | |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
543 |
18906 | 544 ;; Here we must read the output of uncompress program |
545 ;; and write it to TEMP-FILE without any code | |
546 ;; conversion. An appropriate code conversion (if | |
547 ;; necessary) is done by the later I/O operation | |
548 ;; (e.g. load). | |
549 (let ((coding-system-for-read 'no-conversion) | |
550 (coding-system-for-write 'no-conversion)) | |
6002 | 551 |
18906 | 552 (jka-compr-call-process uncompress-program |
553 (concat uncompress-message | |
554 " " base-name) | |
555 local-file | |
556 t | |
557 nil | |
558 uncompress-args) | |
6002 | 559 |
18906 | 560 (and |
561 uncompress-message | |
562 (message "%s %s...done" uncompress-message base-name)) | |
563 | |
564 (write-region | |
565 (point-min) (point-max) temp-file nil 'dont))) | |
6002 | 566 |
567 (and | |
568 local-copy | |
569 (file-exists-p local-copy) | |
570 (delete-file local-copy)) | |
571 | |
572 (kill-buffer temp-buffer)) | |
573 | |
574 temp-file) | |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
575 |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
576 (jka-compr-run-real-handler 'file-local-copy (list filename))))) |
6002 | 577 |
578 | |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
579 ;; Support for loading compressed files. |
6002 | 580 (defun jka-compr-load (file &optional noerror nomessage nosuffix) |
581 "Documented as original." | |
582 | |
583 (let* ((local-copy (jka-compr-file-local-copy file)) | |
584 (load-file (or local-copy file))) | |
585 | |
586 (unwind-protect | |
587 | |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
588 (let (inhibit-file-name-operation |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
589 inhibit-file-name-handlers) |
6002 | 590 (or nomessage |
591 (message "Loading %s..." file)) | |
592 | |
12758
a285eaa710ac
(jka-compr-load): Bind load-force-doc-strings.
Richard M. Stallman <rms@gnu.org>
parents:
11635
diff
changeset
|
593 (let ((load-force-doc-strings t)) |
a285eaa710ac
(jka-compr-load): Bind load-force-doc-strings.
Richard M. Stallman <rms@gnu.org>
parents:
11635
diff
changeset
|
594 (load load-file noerror t t)) |
6002 | 595 (or nomessage |
27512
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
596 (message "Loading %s...done." file)) |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
597 ;; Fix up the load history to point at the right library. |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
598 (let ((l (assoc load-file load-history))) |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
599 ;; Remove .gz and .elc?. |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
600 (while (file-name-extension file) |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
601 (setq file (file-name-sans-extension file))) |
b7020186895e
(jka-compr-load): Fix up load-history.
Dave Love <fx@gnu.org>
parents:
26987
diff
changeset
|
602 (setcar l file))) |
6002 | 603 |
604 (jka-compr-delete-temp-file local-copy)) | |
605 | |
606 t)) | |
12922
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
607 |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
608 (defun jka-compr-byte-compiler-base-file-name (file) |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
609 (let ((info (jka-compr-get-compression-info file))) |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
610 (if (and info (jka-compr-info-strip-extension info)) |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
611 (save-match-data |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
612 (substring file 0 (string-match (jka-compr-info-regexp info) file))) |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
613 file))) |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
614 |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
615 (put 'write-region 'jka-compr 'jka-compr-write-region) |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
616 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents) |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
617 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy) |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
618 (put 'load 'jka-compr 'jka-compr-load) |
12922
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
619 (put 'byte-compiler-base-file-name 'jka-compr |
e171a85fd6b0
(jka-compr-byte-compiler-base-file-name): New function.
Richard M. Stallman <rms@gnu.org>
parents:
12758
diff
changeset
|
620 'jka-compr-byte-compiler-base-file-name) |
6002 | 621 |
61946
982afd92d8bb
Many functions and vars moved to jka-compr-hook.el.
Richard M. Stallman <rms@gnu.org>
parents:
61601
diff
changeset
|
622 ;;;###autoload |
20132
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
623 (defvar jka-compr-inhibit nil |
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
624 "Non-nil means inhibit automatic uncompression temporarily. |
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
625 Lisp programs can bind this to t to do that. |
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
626 It is not recommended to set this variable permanently to anything but nil.") |
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
627 |
61946
982afd92d8bb
Many functions and vars moved to jka-compr-hook.el.
Richard M. Stallman <rms@gnu.org>
parents:
61601
diff
changeset
|
628 ;;;###autoload |
6002 | 629 (defun jka-compr-handler (operation &rest args) |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
630 (save-match-data |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
631 (let ((jka-op (get operation 'jka-compr))) |
20132
b691f68b0757
(jka-compr-inhibit): New variable.
Karl Heuer <kwzh@gnu.org>
parents:
19004
diff
changeset
|
632 (if (and jka-op (not jka-compr-inhibit)) |
7976
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
633 (apply jka-op args) |
b72b84744a85
Use plists to record handlers.
Richard M. Stallman <rms@gnu.org>
parents:
7617
diff
changeset
|
634 (jka-compr-run-real-handler operation args))))) |
6002 | 635 |
7066 | 636 ;; If we are given an operation that we don't handle, |
637 ;; call the Emacs primitive for that operation, | |
638 ;; and manipulate the inhibit variables | |
639 ;; to prevent the primitive from calling our handler again. | |
640 (defun jka-compr-run-real-handler (operation args) | |
641 (let ((inhibit-file-name-handlers | |
642 (cons 'jka-compr-handler | |
643 (and (eq inhibit-file-name-operation operation) | |
644 inhibit-file-name-handlers))) | |
645 (inhibit-file-name-operation operation)) | |
646 (apply operation args))) | |
647 | |
62108
5b31557e355c
(jka-compr-uninstall): Add autoload cookie.
Eli Zaretskii <eliz@gnu.org>
parents:
61946
diff
changeset
|
648 ;;;###autoload |
6002 | 649 (defun jka-compr-uninstall () |
650 "Uninstall jka-compr. | |
7066 | 651 This removes the entries in `file-name-handler-alist' and `auto-mode-alist' |
11296
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
652 and `inhibit-first-line-modes-suffixes' that were added |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
653 by `jka-compr-installed'." |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
654 ;; Delete from inhibit-first-line-modes-suffixes |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
655 ;; what jka-compr-install added. |
69163
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
656 (mapc |
11296
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
657 (function (lambda (x) |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
658 (and (jka-compr-info-strip-extension x) |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
659 (setq inhibit-first-line-modes-suffixes |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
660 (delete (jka-compr-info-regexp x) |
c271ed10f874
(jka-compr-install): Doc fix.
Richard M. Stallman <rms@gnu.org>
parents:
11179
diff
changeset
|
661 inhibit-first-line-modes-suffixes))))) |
69163
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
662 jka-compr-compression-info-list--internal) |
6002 | 663 |
664 (let* ((fnha (cons nil file-name-handler-alist)) | |
665 (last fnha)) | |
666 | |
667 (while (cdr last) | |
668 (if (eq (cdr (car (cdr last))) 'jka-compr-handler) | |
669 (setcdr last (cdr (cdr last))) | |
670 (setq last (cdr last)))) | |
671 | |
672 (setq file-name-handler-alist (cdr fnha))) | |
673 | |
674 (let* ((ama (cons nil auto-mode-alist)) | |
675 (last ama) | |
676 entry) | |
677 | |
678 (while (cdr last) | |
679 (setq entry (car (cdr last))) | |
69163
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
680 (if (or (member entry jka-compr-mode-alist-additions--internal) |
9493
0160fca3dee1
(jka-compr-mode-compression-info-list): Add .tgz extension.
Richard M. Stallman <rms@gnu.org>
parents:
9084
diff
changeset
|
681 (and (consp (cdr entry)) |
0160fca3dee1
(jka-compr-mode-compression-info-list): Add .tgz extension.
Richard M. Stallman <rms@gnu.org>
parents:
9084
diff
changeset
|
682 (eq (nth 2 entry) 'jka-compr))) |
6002 | 683 (setcdr last (cdr (cdr last))) |
684 (setq last (cdr last)))) | |
49597
e88404e8f2cf
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
49418
diff
changeset
|
685 |
19004
f2ce7e947ec9
(jka-compr-added-to-file-coding-system-alist): New var.
Richard M. Stallman <rms@gnu.org>
parents:
18906
diff
changeset
|
686 (setq auto-mode-alist (cdr ama))) |
f2ce7e947ec9
(jka-compr-added-to-file-coding-system-alist): New var.
Richard M. Stallman <rms@gnu.org>
parents:
18906
diff
changeset
|
687 |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
688 (while jka-compr-added-to-file-coding-system-alist |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
689 (setq file-coding-system-alist |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
690 (delq (car (member (pop jka-compr-added-to-file-coding-system-alist) |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
691 file-coding-system-alist)) |
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
692 file-coding-system-alist))) |
39829
79ed34b0c0df
(jka-compr-load-suffixes): New var.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
38412
diff
changeset
|
693 |
79ed34b0c0df
(jka-compr-load-suffixes): New var.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
38412
diff
changeset
|
694 ;; Remove the suffixes that were added by jka-compr. |
69163
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
695 (dolist (suff jka-compr-load-suffixes--internal) |
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
696 (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes))) |
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
697 |
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
698 (setq jka-compr-compression-info-list--internal nil |
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
699 jka-compr-mode-alist-additions--internal nil |
d70e9ee4bf88
(jka-compr-uninstall): Replace `mapcar' with `mapc'.
Luc Teirlinck <teirllm@auburn.edu>
parents:
68651
diff
changeset
|
700 jka-compr-load-suffixes--internal nil)) |
6002 | 701 |
702 (provide 'jka-compr) | |
703 | |
66805
8068044e970e
Require 'jka-cmpr-hook.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
64762
diff
changeset
|
704 ;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc |
38412
253f761ad37b
Some fixes to follow coding conventions in files maintained by FSF.
Pavel Janík <Pavel@Janik.cz>
parents:
34732
diff
changeset
|
705 ;;; jka-compr.el ends here |