Mercurial > hg > xemacs-beta

comparison lisp/prim/format.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents 376386a54a3c
children 441bb1e64a06
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; format.el --- read and save files in multiple formats 1 ;;; format.el --- read and save files in multiple formats
2
2 ;; Copyright (c) 1994, 1995 Free Software Foundation 3 ;; Copyright (c) 1994, 1995 Free Software Foundation
3 4
4 ;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu> 5 ;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu>
6 ;; Keywords: extensions
5 7
6 ;; This file is part of GNU Emacs. 8 ;; This file is part of GNU Emacs.
7 9
8 ;; GNU Emacs is free software; you can redistribute it and/or modify 10 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by 11 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option) 12 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version. 13 ;; any later version.
12 ;; 14
13 ;; GNU Emacs is distributed in the hope that it will be useful, 15 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details. 18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: FSF 19.34.
26
27 ;;; Commentary:
28
29 ;; This file defines a unified mechanism for saving & loading files stored
30 ;; in different formats. `format-alist' contains information that directs
31 ;; Emacs to call an encoding or decoding function when reading or writing
32 ;; files that match certain conditions.
17 ;; 33 ;;
18 ;; You should have received a copy of the GNU General Public License 34 ;; When a file is visited, its format is determined by matching the
19 ;; along with GNU Emacs; see the file COPYING. If not, write to 35 ;; beginning of the file against regular expressions stored in
20 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 36 ;; `format-alist'. If this fails, you can manually translate the buffer
21 37 ;; using `format-decode-buffer'. In either case, the formats used are
22 ;;; Synched up with: FSF 19.30. 38 ;; listed in the variable `buffer-file-format', and become the default
23 39 ;; format for saving the buffer. To save a buffer in a different format,
24 ;;; Commentary: 40 ;; change this variable, or use `format-write-file'.
25 ;; This file defines a unified mechanism for saving & loading files stored in
26 ;; different formats. `format-alist' contains information that directs
27 ;; Emacs to call an encoding or decoding function when reading or writing
28 ;; files that match certain conditions.
29 ;;
30 ;; When a file is visited, its format is determined by matching the beginning
31 ;; of the file against regular expressions stored in `format-alist'. If this
32 ;; fails, you can manually translate the buffer using `format-decode-buffer'.
33 ;; In either case, the formats used are listed in the variable
34 ;; `buffer-file-format', and become the default format for saving the buffer.
35 ;; To save a buffer in a different format, change this variable, or use
36 ;; `format-write-file'.
37 ;; 41 ;;
38 ;; Auto-save files are normally created in the same format as the visited 42 ;; Auto-save files are normally created in the same format as the visited
39 ;; file, but the variable `auto-save-file-format' can be set to a particularly 43 ;; file, but the variable `auto-save-file-format' can be set to a
40 ;; fast or otherwise preferred format to be used for auto-saving (or nil to do 44 ;; particularly fast or otherwise preferred format to be used for
41 ;; no encoding on auto-save files, but then you risk losing any 45 ;; auto-saving (or nil to do no encoding on auto-save files, but then you
42 ;; text-properties in the buffer). 46 ;; risk losing any text-properties in the buffer).
43 ;; 47 ;;
44 ;; You can manually translate a buffer into or out of a particular format with 48 ;; You can manually translate a buffer into or out of a particular format
45 ;; the functions `format-encode-buffer' and `format-decode-buffer'. 49 ;; with the functions `format-encode-buffer' and `format-decode-buffer'.
46 ;; To translate just the region use the functions `format-encode-region' and 50 ;; To translate just the region use the functions `format-encode-region'
47 ;; `format-decode-region'. 51 ;; and `format-decode-region'.
48 ;; 52 ;;
49 ;; You can define a new format by writing the encoding and decoding functions, 53 ;; You can define a new format by writing the encoding and decoding
50 ;; and adding an entry to `format-alist'. See enriched.el for an example of 54 ;; functions, and adding an entry to `format-alist'. See enriched.el for
51 ;; how to implement a file format. There are various functions defined 55 ;; an example of how to implement a file format. There are various
52 ;; in this file that may be useful for writing the encoding and decoding 56 ;; functions defined in this file that may be useful for writing the
53 ;; functions: 57 ;; encoding and decoding functions:
54 ;; * `format-annotate-region' and `format-deannotate-region' allow a single 58 ;; * `format-annotate-region' and `format-deannotate-region' allow a
55 ;; alist of information to be used for encoding and decoding. The alist 59 ;; single alist of information to be used for encoding and decoding.
56 ;; defines a correspondence between strings in the file ("annotations") 60 ;; The alist defines a correspondence between strings in the file
57 ;; and text-properties in the buffer. 61 ;; ("annotations") and text-properties in the buffer.
58 ;; * `format-replace-strings' is similarly useful for doing simple 62 ;; * `format-replace-strings' is similarly useful for doing simple
59 ;; string->string translations in a reversible manner. 63 ;; string->string translations in a reversible manner.
64
65 ;;; Code:
60 66
61 (put 'buffer-file-format 'permanent-local t) 67 (put 'buffer-file-format 'permanent-local t)
62 68
63 (defconst format-alist 69 (defconst format-alist
64 '((text/enriched "Extended MIME text/enriched format." 70 '((text/enriched "Extended MIME text/enriched format."
468 ;; If no matching annotation is open, just ignore the close. 474 ;; If no matching annotation is open, just ignore the close.
469 (if (not (assoc name open-ans)) 475 (if (not (assoc name open-ans))
470 (message "Extra closing annotation (%s) in file" name) 476 (message "Extra closing annotation (%s) in file" name)
471 ;; If one is open, but not on the top of the stack, close 477 ;; If one is open, but not on the top of the stack, close
472 ;; the things in between as well. Set `found' when the real 478 ;; the things in between as well. Set `found' when the real
473 ;; oneis closed. 479 ;; one is closed.
474 (while (not found) 480 (while (not found)
475 (let* ((top (car open-ans)) ; first on stack: should match. 481 (let* ((top (car open-ans)) ; first on stack: should match.
476 (top-name (car top)) 482 (top-name (car top))
477 (start (car (cdr top))) ; location of start 483 (start (car (cdr top))) ; location of start
478 (params (cdr (cdr top))) ; parameters 484 (params (cdr (cdr top))) ; parameters
495 (if (member 'nil (mapcar 501 (if (member 'nil (mapcar
496 (lambda (r) 502 (lambda (r)
497 (assoc r open-ans)) 503 (assoc r open-ans))
498 ans)) 504 ans))
499 nil ; multiple ans not satisfied 505 nil ; multiple ans not satisfied
500 ;; Yes, use the current property name & 506 ;; Yes, all set.
501 ;; value. Set loop variables to nil so loop 507 ;; If there are multiple annotations going
508 ;; into one text property, adjust the
509 ;; begin points of the other annotations
510 ;; so that we don't get double marking.
511 (let ((to-reset ans)
512 this-one)
513 (while to-reset
514 (setq this-one
515 (assoc (car to-reset)
516 (cdr open-ans)))
517 (if this-one
518 (setcdr this-one (list loc)))
519 (setq to-reset (cdr to-reset))))
520 ;; Set loop variables to nil so loop
502 ;; will exit. 521 ;; will exit.
503 (setq alist nil aalist nil matched t 522 (setq alist nil aalist nil matched t
504 ;; pop annotation off stack. 523 ;; pop annotation off stack.
505 open-ans (cdr open-ans)) 524 open-ans (cdr open-ans))
506 (cond 525 (cond
732 (let ((prop-alist (cdr (assoc prop trans))) 751 (let ((prop-alist (cdr (assoc prop trans)))
733 default) 752 default)
734 (if (not prop-alist) 753 (if (not prop-alist)
735 nil 754 nil
736 ;; If property is numeric, nil means 0 755 ;; If property is numeric, nil means 0
737 (cond ((and (numberp old) (null new) 756 (cond ((and (numberp old) (null new))
738 (numberp (car (car prop-alist))))
739 (setq new 0)) 757 (setq new 0))
740 ((and (numberp new) (null old) 758 ((and (numberp new) (null old))
741 (numberp (car (car prop-alist))))
742 (setq old 0))) 759 (setq old 0)))
743 ;; If either old or new is a list, have to treat both that way. 760 ;; If either old or new is a list, have to treat both that way.
744 (if (or (consp old) (consp new)) 761 (if (or (consp old) (consp new))
745 (let* ((old (if (listp old) old (list old))) 762 (let* ((old (if (listp old) old (list old)))
746 (new (if (listp new) new (list new))) 763 (new (if (listp new) new (list new)))
761 (format-make-relatively-unique close open)) 778 (format-make-relatively-unique close open))
762 (format-annotate-atomic-property-change prop-alist old new))))) 779 (format-annotate-atomic-property-change prop-alist old new)))))
763 780
764 (defun format-annotate-atomic-property-change (prop-alist old new) 781 (defun format-annotate-atomic-property-change (prop-alist old new)
765 "Internal function annotate a single property change. 782 "Internal function annotate a single property change.
766 PROP-ALIST is the relevant segement of a TRANSLATIONS list. 783 PROP-ALIST is the relevant segment of a TRANSLATIONS list.
767 OLD and NEW are the values." 784 OLD and NEW are the values."
768 (cond 785 (cond
769 ;; Numerical annotation - use difference 786 ;; Numerical annotation - use difference
770 ((and (numberp old) (numberp new) 787 ((and (numberp old) (numberp new))
771 (numberp (car (car prop-alist))))
772 (let* ((entry (progn 788 (let* ((entry (progn
773 (while (and (car (car prop-alist)) 789 (while (and (car (car prop-alist))
774 (not (numberp (car (car prop-alist))))) 790 (not (numberp (car (car prop-alist)))))
775 (setq prop-alist (cdr prop-alist))) 791 (setq prop-alist (cdr prop-alist)))
776 (car prop-alist))) 792 (car prop-alist)))