;;; format.el --- read and save files in multiple formats
-;; Copyright (C) 1994, 1995, 1997, 1999, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1994-1995, 1997, 1999, 2001-2016 Free Software
+;; Foundation, Inc.
;; Author: Boris Goldowsky <boris@gnu.org>
+;; Package: emacs
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(put 'buffer-auto-save-file-format 'permanent-local t)
(defvar format-alist
- '((text/enriched "Extended MIME text/enriched format."
- "Content-[Tt]ype:[ \t]*text/enriched"
+ ;; FIXME: maybe each item can be purecopied instead of just the strings.
+ `((text/enriched ,(purecopy "Extended MIME text/enriched format.")
+ ,(purecopy "Content-[Tt]ype:[ \t]*text/enriched")
enriched-decode enriched-encode t enriched-mode)
- (plain "ISO 8859-1 standard format, no text properties."
+ (plain ,(purecopy "ISO 8859-1 standard format, no text properties.")
;; Plain only exists so that there is an obvious neutral choice in
;; the completion list.
nil nil nil nil nil)
- (ibm "IBM Code Page 850 (DOS)"
- nil ; The original "1\\(^\\)" is obscure.
- "recode -f ibm-pc:latin1" "recode -f latin1:ibm-pc" t nil)
- (mac "Apple Macintosh"
- nil
- "recode -f mac:latin1" "recode -f latin1:mac" t nil)
- (hp "HP Roman8"
- nil
- "recode -f roman8:latin1" "recode -f latin1:roman8" t nil)
- (TeX "TeX (encoding)"
+ (TeX ,(purecopy "TeX (encoding)")
nil
iso-tex2iso iso-iso2tex t nil)
- (gtex "German TeX (encoding)"
+ (gtex ,(purecopy "German TeX (encoding)")
nil
iso-gtex2iso iso-iso2gtex t nil)
- (html "HTML/SGML \"ISO 8879:1986//ENTITIES Added Latin 1//EN\" (encoding)"
+ (html ,(purecopy "HTML/SGML \"ISO 8879:1986//ENTITIES Added Latin 1//EN\" (encoding)")
nil
iso-sgml2iso iso-iso2sgml t nil)
- (rot13 "rot13"
+ (rot13 ,(purecopy "rot13")
nil
- "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil)
- (duden "Duden Ersatzdarstellung"
+ ,(purecopy "tr a-mn-z n-za-m") ,(purecopy "tr a-mn-z n-za-m") t nil)
+ (duden ,(purecopy "Duden Ersatzdarstellung")
nil
- "diac" iso-iso2duden t nil)
- (de646 "German ASCII (ISO 646)"
+ ,(purecopy "diac") iso-iso2duden t nil)
+ (de646 ,(purecopy "German ASCII (ISO 646)")
nil
- "recode -f iso646-ge:latin1" "recode -f latin1:iso646-ge" t nil)
- (denet "net German"
+ ,(purecopy "recode -f iso646-ge:latin1")
+ ,(purecopy "recode -f latin1:iso646-ge") t nil)
+ (denet ,(purecopy "net German")
nil
iso-german iso-cvt-read-only t nil)
- (esnet "net Spanish"
+ (esnet ,(purecopy "net Spanish")
nil
iso-spanish iso-cvt-read-only t nil))
"List of information about understood file formats.
-Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN).
+Elements are of the form
+\(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN PRESERVE).
NAME is a symbol, which is stored in `buffer-file-format'.
the user if they ask for more information.
REGEXP is a regular expression to match against the beginning of the file;
- it should match only files in that format. Use nil to avoid
- matching at all for formats for which it isn't appropriate to
- require explicit encoding/decoding.
+ it should match only files in that format. REGEXP may be nil, in
+ which case the format will never be applied automatically to a file.
+ Use this for formats that you only ever want to apply manually.
FROM-FN is called to decode files in that format; it takes two args, BEGIN
and END, and can make any modifications it likes, returning the new
that this would turn on some minor mode.
PRESERVE, if non-nil, means that `format-write-file' should not remove
- this format from `buffer-file-formats'.")
+ this format from `buffer-file-format'.")
+;;;###autoload
+(put 'format-alist 'risky-local-variable t)
;;; Basic Functions (called from Lisp)
(error "Format encoding failed")))
(funcall method from to buffer)))
-(defun format-decode-run-method (method from to &optional buffer)
+(defun format-decode-run-method (method from to &optional _buffer)
"Decode using METHOD the text from FROM to TO.
If METHOD is a string, it is a shell command (including options); otherwise,
-it should be a Lisp function. Decoding is done for the given BUFFER."
+it should be a Lisp function. BUFFER is currently ignored."
(if (stringp method)
(let ((error-buff (get-buffer-create "*Format Errors*"))
(coding-system-for-write 'no-conversion)
;; We should perhaps go via a temporary buffer and copy it
;; back, in case of errors.
(if (and (zerop (save-window-excursion
- (shell-command-on-region (point-min) (point-max)
- method t t
+ (shell-command-on-region from to method t t
error-buff)))
;; gzip gives zero exit status with bad args, for instance.
(zerop (with-current-buffer error-buff
(setq selective-display sel-disp)
(set-buffer-multibyte multibyte)
(setq buffer-file-coding-system coding-system))
- (copy-to-buffer copy-buf from to)
- (set-buffer copy-buf)
- (format-insert-annotations write-region-annotations-so-far from)
- (format-encode-run-method to-fn (point-min) (point-max) orig-buf)
+ (let ((inhibit-read-only t)) ; bug#14887
+ (copy-to-buffer copy-buf from to)
+ (set-buffer copy-buf)
+ (format-insert-annotations write-region-annotations-so-far from)
+ (format-encode-run-method to-fn (point-min) (point-max)
+ orig-buf))
+ (when (buffer-live-p copy-buf)
+ (with-current-buffer copy-buf
+ ;; Set write-region-post-annotation-function to
+ ;; delete the buffer once the write is done, but do
+ ;; it after running to-fn so it doesn't affect
+ ;; write-region calls in to-fn.
+ (set (make-local-variable
+ 'write-region-post-annotation-function)
+ 'kill-buffer)))
nil)
;; Otherwise just call function, it will return annotations.
(funcall to-fn from to orig-buf)))))
(if (symbolp format) (setq format (list format)))
(save-excursion
(goto-char end)
- (let ((cur-buf (current-buffer))
- (end (point-marker)))
+ (let ((end (point-marker)))
(while format
(let* ((info (assq (car format) format-alist))
(to-fn (nth 4 info))
- (modify (nth 5 info))
- result)
+ (modify (nth 5 info)))
(if to-fn
(if modify
(setq end (format-encode-run-method to-fn beg end
(setq format (cdr format)))))))
(defun format-write-file (filename format &optional confirm)
- "Write current buffer into file FILENAME using some FORMAT.
-Make buffer visit that file and set the format as the default for future
-saves. If the buffer is already visiting a file, you can specify a directory
-name as FILENAME, to write a file of the same old name in that directory.
-
-If optional third arg CONFIRM is non-nil, ask for confirmation before
-overwriting an existing file. Interactively, confirmation is required
+ "Write current buffer into FILENAME, using a format based on FORMAT.
+Constructs the actual format starting from FORMAT, then appending
+any elements from the value of `buffer-file-format' with a non-nil
+`preserve' flag (see the documentation of `format-alist'), if they
+are not already present in FORMAT. It then updates `buffer-file-format'
+with this format, making it the default for future saves.
+
+If the buffer is already visiting a file, you can specify a
+directory name as FILENAME, to write a file of the same old name
+in that directory.
+
+If optional third arg CONFIRM is non-nil, asks for confirmation before
+overwriting an existing file. Interactively, requires confirmation
unless you supply a prefix argument."
(interactive
;; Same interactive spec as write-file, plus format question.
(cdr (assq 'default-directory
(buffer-local-variables)))
nil nil (buffer-name))))
- (fmt (format-read (format "Write file `%s' in format: "
- (file-name-nondirectory file)))))
+ (fmt (format-read (format-message "Write file `%s' in format: "
+ (file-name-nondirectory file)))))
(list file fmt (not current-prefix-arg))))
(let ((old-formats buffer-file-format)
preserve-formats)
(interactive
;; Same interactive spec as write-file, plus format question.
(let* ((file (read-file-name "Find file: "))
- (fmt (format-read (format "Read file `%s' in format: "
- (file-name-nondirectory file)))))
+ (fmt (format-read (format-message "Read file `%s' in format: "
+ (file-name-nondirectory file)))))
(list file fmt)))
(let ((format-alist nil))
(find-file filename))
(interactive
;; Same interactive spec as write-file, plus format question.
(let* ((file (read-file-name "Find file: "))
- (fmt (format-read (format "Read file `%s' in format: "
- (file-name-nondirectory file)))))
+ (fmt (format-read (format-message "Read file `%s' in format: "
+ (file-name-nondirectory file)))))
(list file fmt)))
- (let (value size)
- (let ((format-alist nil))
- (setq value (insert-file-contents filename nil beg end))
- (setq size (nth 1 value)))
- (if format
- (setq size (format-decode format size)
- value (list (car value) size)))
+ (let (value size old-undo)
+ ;; Record only one undo entry for the insertion. Inhibit point-motion and
+ ;; modification hooks as with `insert-file-contents'.
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t))
+ ;; Don't bind `buffer-undo-list' to t here to assert that
+ ;; `insert-file-contents' may record whether the buffer was unmodified
+ ;; before.
+ (let ((format-alist nil))
+ (setq value (insert-file-contents filename nil beg end))
+ (setq size (nth 1 value)))
+ (when (consp buffer-undo-list)
+ (let ((head (car buffer-undo-list)))
+ (when (and (consp head)
+ (equal (car head) (point))
+ (equal (cdr head) (+ (point) size)))
+ ;; Remove first entry from `buffer-undo-list', we shall insert
+ ;; another one below.
+ (setq old-undo (cdr buffer-undo-list)))))
+ (when format
+ (let ((buffer-undo-list t))
+ (setq size (format-decode format size)
+ value (list (car value) size)))
+ (unless (eq buffer-undo-list t)
+ (setq buffer-undo-list
+ (cons (cons (point) (+ (point) size)) old-undo)))))
+ (unless inhibit-modification-hooks
+ (run-hook-with-args 'after-change-functions (point) (+ (point) size) 0))
value))
(defun format-read (&optional prompt)
(defun format-delq-cons (cons list)
"Remove the given CONS from LIST by side effect and return the new LIST.
Since CONS could be the first element of LIST, write
-`\(setq foo \(format-delq-cons element foo))' to be sure of changing
+\(setq foo \(format-delq-cons element foo)) to be sure of changing
the value of `foo'."
(if (eq cons list)
(cdr list)
(setq tail next)))
(cons acopy bcopy)))
-(defun format-common-tail (a b)
- "Given two lists that have a common tail, return it.
-Compare with `equal', and return the part of A that is equal to the
-equivalent part of B. If even the last items of the two are not equal,
-return nil."
- (let ((la (length a))
- (lb (length b)))
- ;; Make sure they are the same length
- (if (> la lb)
- (setq a (nthcdr (- la lb) a))
- (setq b (nthcdr (- lb la) b))))
- (while (not (equal a b))
- (setq a (cdr a)
- b (cdr b)))
- a)
-
(defun format-proper-list-p (list)
"Return t if LIST is a proper list.
A proper list is a list ending with a nil cdr, not with an atom "
Any annotations that are found by NEXT-FN but not defined by TRANSLATIONS
are saved as values of the `unknown' text-property \(which is list-valued).
The TRANSLATIONS list should usually contain an entry of the form
- \(unknown \(nil format-annotate-value))
+ (unknown (nil format-annotate-value))
to write these unknown annotations back into the file."
(save-excursion
(save-restriction
(narrow-to-region (point-min) to)
(goto-char from)
- (let (next open-ans todo loc unknown-ans)
+ (let (next open-ans todo unknown-ans)
(while (setq next (funcall next-fn))
(let* ((loc (nth 0 next))
(end (nth 1 next))
Insert each element of the given LIST of buffer annotations at its
appropriate place. Use second arg OFFSET if the annotations' locations are
not relative to the beginning of the buffer: annotations will be inserted
-at their location-OFFSET+1 \(ie, the offset is treated as the position of
+at their location-OFFSET+1 \(i.e., the offset is treated as the position of
the first character in the buffer)."
(if (not offset)
(setq offset 0)
(setq l (cdr l)))))
(defun format-annotate-value (old new)
- "Return OLD and NEW as a \(CLOSE . OPEN) annotation pair.
+ "Return OLD and NEW as a (CLOSE . OPEN) annotation pair.
Useful as a default function for TRANSLATIONS alist when the value of the text
property is the name of the annotation that you want to use, as it is for the
`unknown' text property."
all-ans))
(setq neg-ans (cdr neg-ans)))
;; Now deal with positive (opening) annotations
- (let ((p pos-ans))
- (while pos-ans
- (push (car pos-ans) open-ans)
- (push (cons loc (funcall format-fn (car pos-ans) t))
- all-ans)
- (setq pos-ans (cdr pos-ans))))))
+ (while pos-ans
+ (push (car pos-ans) open-ans)
+ (push (cons loc (funcall format-fn (car pos-ans) t))
+ all-ans)
+ (setq pos-ans (cdr pos-ans)))))
;; Close any annotations still open
(while open-ans
can handle. If that is `enriched-make-annotation', they can be
either strings, or lists of the form (PARAMETER VALUE)."
- (let ((prop-alist (cdr (assoc prop translations)))
- default)
+ (let ((prop-alist (cdr (assoc prop translations))))
(if (not prop-alist)
nil
;; If either old or new is a list, have to treat both that way.
(format-annotate-atomic-property-change prop-alist old new)
(let* ((old (if (listp old) old (list old)))
(new (if (listp new) new (list new)))
- (tail (format-common-tail old new))
close open)
(while old
(setq close
(provide 'format)
-;;; arch-tag: c387e9c7-a93d-47bf-89bc-8ca67e96755a
;;; format.el ends here