-;;; enriched.el -- read and save files in text/enriched format
-;; Copyright (c) 1994, 1995 Free Software Foundation, Inc.
+;;; enriched.el --- read and save files in text/enriched format
-;; Author: Boris Goldowsky <boris@gnu.ai.mit.edu>
+;; Copyright (c) 1994, 1995, 1996, 2002 Free Software Foundation, Inc.
+
+;; Author: Boris Goldowsky <boris@gnu.org>
;; Keywords: wp, faces
;; This file is part of GNU Emacs.
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
-;;
+
;; This file implements reading, editing, and saving files with
-;; text-properties such as faces, levels of indentation, and true line breaks
-;; distinguished from newlines just used to fit text into the window.
-;;
+;; text-properties such as faces, levels of indentation, and true line
+;; breaks distinguished from newlines just used to fit text into the window.
+
;; The file format used is the MIME text/enriched format, which is a
-;; standard format defined in internet RFC 1563. All standard annotations are
-;; supported except for <smaller> and <bigger>, which are currently not
+;; standard format defined in internet RFC 1563. All standard annotations
+;; are supported except for <smaller> and <bigger>, which are currently not
;; possible to display.
-;;
+
;; A separate file, enriched.doc, contains further documentation and other
-;; important information about this code. It also serves as an example file
-;; in text/enriched format. It should be in the etc directory of your emacs
-;; distribution.
+;; important information about this code. It also serves as an example
+;; file in text/enriched format. It should be in the etc directory of your
+;; emacs distribution.
+
+;;; Code:
(provide 'enriched)
-(if window-system (require 'facemenu))
;;;
;;; Variables controlling the display
;;;
-(defvar enriched-verbose t
- "*If non-nil, give status messages when reading and writing files.")
+(defgroup enriched nil
+ "Read and save files in text/enriched format"
+ :group 'wp)
-(defvar enriched-default-right-margin 10
- "*Default amount of space to leave on the right edge of the screen.
-This can be increased inside text by changing the 'right-margin text property.
-Measured in character widths. If the screen is narrower than this, it is
-assumed to be 0.")
-
-(defvar enriched-fill-after-visiting t
- "If t, fills paragraphs when reading in enriched documents.
-If nil, only fills when you explicitly request it. If the value is 'ask, then
-it will query you whether to fill.
-Filling is never done if the current text-width is the same as the value
-stored in the file.")
+(defcustom enriched-verbose t
+ "*If non-nil, give status messages when reading and writing files."
+ :type 'boolean
+ :group 'enriched)
;;;
;;; Set up faces & display table
;;;
-;; A slight cheat - all emacs's faces are fixed-width.
-;; The idea is just to pick one that looks different from the default.
-(if (internal-find-face 'fixed)
- nil
- (make-face 'fixed)
- (if window-system
- (set-face-font 'fixed
- (car (or (x-list-fonts "*fixed-medium*"
- 'default (selected-frame))
- (x-list-fonts "*fixed*"
- 'default (selected-frame)))))))
-
-(if (internal-find-face 'excerpt)
- nil
- (make-face 'excerpt)
- (if window-system
- (make-face-italic 'excerpt nil t)))
+;; Emacs doesn't have a "fixed" face by default, since all faces currently
+;; have to be fixed-width. So we just pick one that looks different from the
+;; default.
+(defface fixed
+ '((t (:weight bold)))
+ "Face used for text that must be shown in fixed width.
+Currently, emacs can only display fixed-width fonts, but this may change.
+This face is used for text specifically marked as fixed-width, for example
+in text/enriched files."
+ :group 'enriched)
+
+(defface excerpt
+ '((t (:slant italic)))
+ "Face used for text that is an excerpt from another document.
+This is used in Enriched mode for text explicitly marked as an excerpt."
+ :group 'enriched)
(defconst enriched-display-table (or (copy-sequence standard-display-table)
(make-display-table)))
(defconst enriched-initial-annotation
(lambda ()
(format "Content-Type: text/enriched\nText-Width: %d\n\n"
- (enriched-text-width)))
+ fill-column))
"What to insert at the start of a text/enriched file.
If this is a string, it is inserted. If it is a list, it should be a lambda
expression, which is evaluated to get the string to insert.")
(defconst enriched-annotation-format "<%s%s>"
"General format of enriched-text annotations.")
-(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-za-z0-9]+\\)>"
+(defconst enriched-annotation-regexp "<\\(/\\)?\\([-A-Za-z0-9]+\\)>"
"Regular expression matching enriched-text annotations.")
(defconst enriched-translations
(right "flushright")
(left "flushleft")
(full "flushboth")
- (center "center"))
+ (center "center"))
(PARAMETER (t "param")) ; Argument of preceding annotation
;; The following are not part of the standard:
(FUNCTION (enriched-decode-foreground "x-color")
- (enriched-decode-background "x-bg-color"))
+ (enriched-decode-background "x-bg-color")
+ (enriched-decode-display-prop "x-display"))
(read-only (t "x-read-only"))
+ (display (nil enriched-handle-display-prop))
(unknown (nil format-annotate-value))
; (font-size (2 "bigger") ; unimplemented
; (-2 "smaller"))
;;; Internal variables
-(defvar enriched-mode nil
- "True if `enriched-mode' is in use.")
-(make-variable-buffer-local 'enriched-mode)
-
-(if (not (assq 'enriched-mode minor-mode-alist))
- (setq minor-mode-alist
- (cons '(enriched-mode " Enriched")
- minor-mode-alist)))
-(defvar enriched-mode-hooks nil
- "Functions to run when entering `enriched-mode'.
+(defcustom enriched-mode-hook nil
+ "Hook run after entering/leaving Enriched mode.
If you set variables in this hook, you should arrange for them to be restored
-to their old values if enriched-mode is left. One way to do this is to add
-them and their old values to `enriched-old-bindings'.")
+to their old values if you leave Enriched mode. One way to do this is to add
+them and their old values to `enriched-old-bindings'."
+ :type 'hook
+ :group 'enriched)
(defvar enriched-old-bindings nil
"Store old variable values that we change when entering mode.
The value is a list of \(VAR VALUE VAR VALUE...).")
(make-variable-buffer-local 'enriched-old-bindings)
-(defvar enriched-text-width nil)
-(make-variable-buffer-local 'enriched-text-width)
-
;;;
;;; Define the mode
;;;
+(put 'enriched-mode 'permanent-local t)
;;;###autoload
-(defun enriched-mode (&optional arg)
+(define-minor-mode enriched-mode
"Minor mode for editing text/enriched files.
These are files with embedded formatting information in the MIME standard
text/enriched format.
-Turning the mode on runs `enriched-mode-hooks'.
+Turning the mode on runs `enriched-mode-hook'.
-More information about enriched-mode is available in the file
-etc/enriched.doc in the Emacs distribution directory.
+More information about Enriched mode is available in the file
+etc/enriched.doc in the Emacs distribution directory.
Commands:
-\\<enriched-mode-map>\\{enriched-mode-map}"
- (interactive "P")
- (let ((mod (buffer-modified-p)))
- (cond ((or (<= (prefix-numeric-value arg) 0)
- (and enriched-mode (null arg)))
- ;; Turn mode off
- (setq enriched-mode nil)
- (setq buffer-file-format (delq 'text/enriched buffer-file-format))
- ;; restore old variable values
- (while enriched-old-bindings
- (funcall 'set (car enriched-old-bindings)
- (car (cdr enriched-old-bindings)))
- (setq enriched-old-bindings (cdr (cdr enriched-old-bindings)))))
-
- (enriched-mode nil) ; Mode already on; do nothing.
-
- (t (setq enriched-mode t) ; Turn mode on
- (if (not (memq 'text/enriched buffer-file-format))
- (setq buffer-file-format
- (cons 'text/enriched buffer-file-format)))
- ;; Save old variable values before we change them.
- ;; These will be restored if we exit enriched-mode.
- (setq enriched-old-bindings
- (list 'buffer-display-table buffer-display-table
- 'indent-line-function indent-line-function
- 'use-hard-newlines use-hard-newlines
- 'default-text-properties default-text-properties))
- (make-local-variable 'indent-line-function)
- (make-local-variable 'use-hard-newlines)
- (make-local-variable 'default-text-properties)
- (setq indent-line-function 'indent-to-left-margin
- buffer-display-table enriched-display-table
- use-hard-newlines t)
- (let ((sticky (plist-get default-text-properties 'front-sticky))
- (p enriched-par-props))
- (while p
- (if (not (memq (car p) sticky))
- (setq sticky (cons (car p) sticky)))
- (setq p (cdr p)))
- (if sticky
- (setq default-text-properties
- (plist-put default-text-properties
- 'front-sticky sticky))))
- (run-hooks 'enriched-mode-hooks)))
- (set-buffer-modified-p mod)
- (force-mode-line-update)))
+\\{enriched-mode-map}"
+ nil " Enriched" nil
+ (cond ((null enriched-mode)
+ ;; Turn mode off
+ (setq buffer-file-format (delq 'text/enriched buffer-file-format))
+ ;; restore old variable values
+ (while enriched-old-bindings
+ (set (pop enriched-old-bindings) (pop enriched-old-bindings))))
+
+ ((memq 'text/enriched buffer-file-format)
+ ;; Mode already on; do nothing.
+ nil)
+
+ (t ; Turn mode on
+ (push 'text/enriched buffer-file-format)
+ ;; Save old variable values before we change them.
+ ;; These will be restored if we exit Enriched mode.
+ (setq enriched-old-bindings
+ (list 'buffer-display-table buffer-display-table
+ 'indent-line-function indent-line-function
+ 'default-text-properties default-text-properties))
+ (make-local-variable 'indent-line-function)
+ (make-local-variable 'default-text-properties)
+ (setq indent-line-function 'indent-to-left-margin ;WHY?? -sm
+ buffer-display-table enriched-display-table)
+ (use-hard-newlines 1 nil)
+ (let ((sticky (plist-get default-text-properties 'front-sticky))
+ (p enriched-par-props))
+ (dolist (x p)
+ (add-to-list 'sticky x))
+ (if sticky
+ (setq default-text-properties
+ (plist-put default-text-properties
+ 'front-sticky sticky)))))))
;;;
;;; Keybindings
;;;
(defvar enriched-mode-map nil
- "Keymap for `enriched-mode'.")
+ "Keymap for Enriched mode.")
(if (null enriched-mode-map)
(fset 'enriched-mode-map (setq enriched-mode-map (make-sparse-keymap))))
(justify-current-line t nil t))
(forward-line 1)))))
-(defun enriched-text-width ()
- "The width of unindented text in this window, in characters.
-This is the width of the window minus `enriched-default-right-margin'."
- (or enriched-text-width
- (let ((ww (window-width)))
- (setq enriched-text-width
- (if (> ww enriched-default-right-margin)
- (- ww enriched-default-right-margin)
- ww)))))
-
;;;
;;; Encoding Files
;;;
;;;###autoload
-(defun enriched-encode (from to)
+(defun enriched-encode (from to orig-buf)
(if enriched-verbose (message "Enriched: encoding document..."))
(save-restriction
(narrow-to-region from to)
(unjustify-region)
(goto-char from)
(format-replace-strings '(("<" . "<<")))
- (format-insert-annotations
+ (format-insert-annotations
(format-annotate-region from (point-max) enriched-translations
'enriched-make-annotation enriched-ignore))
(goto-char from)
(insert (if (stringp enriched-initial-annotation)
enriched-initial-annotation
- (funcall enriched-initial-annotation)))
+ (save-excursion
+ ;; Eval this in the buffer we are annotating. This
+ ;; fixes a bug which was saving incorrect File-Width
+ ;; information, since we were looking at local
+ ;; variables in the wrong buffer.
+ (if orig-buf (set-buffer orig-buf))
+ (funcall enriched-initial-annotation))))
(enriched-map-property-regions 'hard
(lambda (v b e)
(if (and v (= ?\n (char-after b)))
;; Return new end.
(point-max)))
-(defun enriched-make-annotation (name positive)
- "Format an annotation called NAME.
-If POSITIVE is non-nil, this is the opening annotation, if nil, this is the
-matching close."
- (cond ((stringp name)
- (format enriched-annotation-format (if positive "" "/") name))
+(defun enriched-make-annotation (internal-ann positive)
+ "Format an annotation INTERNAL-ANN.
+INTERNAL-ANN may be a string, for a flag, or a list of the form (PARAM VALUE).
+If POSITIVE is non-nil, this is the opening annotation;
+if nil, the matching close."
+ (cond ((stringp internal-ann)
+ (format enriched-annotation-format (if positive "" "/") internal-ann))
;; Otherwise it is an annotation with parameters, represented as a list
(positive
- (let ((item (car name))
- (params (cdr name)))
+ (let ((item (car internal-ann))
+ (params (cdr internal-ann)))
(concat (format enriched-annotation-format "" item)
(mapconcat (lambda (i) (concat "<param>" i "</param>"))
params ""))))
- (t (format enriched-annotation-format "/" (car name)))))
+ (t (format enriched-annotation-format "/" (car internal-ann)))))
(defun enriched-encode-other-face (old new)
"Generate annotations for random face change.
One annotation each for foreground color, background color, italic, etc."
(cons (and old (enriched-face-ans old))
(and new (enriched-face-ans new))))
-
+
(defun enriched-face-ans (face)
- "Return annotations specifying FACE."
- (cond ((string-match "^fg:" (symbol-name face))
- (list (list "x-color" (substring (symbol-name face) 3))))
- ((string-match "^bg:" (symbol-name face))
- (list (list "x-bg-color" (substring (symbol-name face) 3))))
- ((let* ((fg (face-foreground face))
- (bg (face-background face))
+ "Return annotations specifying FACE.
+FACE may be a list of faces instead of a single face;
+it can also be anything allowed as an element of a list
+which can be the value of the `face' text property."
+ (cond ((and (consp face) (eq (car face) 'foreground-color))
+ (list (list "x-color" (cdr face))))
+ ((and (consp face) (eq (car face) 'background-color))
+ (list (list "x-bg-color" (cdr face))))
+ ((and (listp face) (eq (car face) :foreground))
+ (list (list "x-color" (cadr face))))
+ ((and (listp face) (eq (car face) :background))
+ (list (list "x-bg-color" (cadr face))))
+ ((listp face)
+ (apply 'append (mapcar 'enriched-face-ans face)))
+ ((let* ((fg (face-attribute face :foreground))
+ (bg (face-attribute face :background))
(props (face-font face t))
(ans (cdr (format-annotate-single-property-change
'face nil props enriched-translations))))
- (if fg (setq ans (cons (list "x-color" fg) ans)))
- (if bg (setq ans (cons (list "x-bg-color" bg) ans)))
+ (unless (eq fg 'unspecified)
+ (setq ans (cons (list "x-color" fg) ans)))
+ (unless (eq bg 'unspecified)
+ (setq ans (cons (list "x-bg-color" bg) ans)))
ans))))
;;;
;;;###autoload
(defun enriched-decode (from to)
(if enriched-verbose (message "Enriched: decoding document..."))
+ (use-hard-newlines 1 'never)
(save-excursion
(save-restriction
(narrow-to-region from to)
(goto-char from)
- (let ((file-width (enriched-get-file-width))
- (use-hard-newlines t))
+
+ ;; Deal with header
+ (let ((file-width (enriched-get-file-width)))
(enriched-remove-header)
;; Deal with newlines
- (goto-char from)
(while (search-forward-regexp "\n\n+" nil t)
(if (current-justification)
(delete-char -1))
- (put-text-property (match-beginning 0) (point) 'hard t)
- (put-text-property (match-beginning 0) (point) 'front-sticky nil))
+ (set-hard-newline-properties (match-beginning 0) (point)))
;; Translate annotations
(format-deannotate-region from (point-max) enriched-translations
'enriched-next-annotation)
- ;; Fill paragraphs
- (if (or (and file-width ; possible reasons not to fill:
- (= file-width (enriched-text-width))) ; correct wd.
- (null enriched-fill-after-visiting) ; never fill
- (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
- (not (y-or-n-p "Re-fill for current display width? "))))
- ;; Minimally, we have to insert indentation and justification.
- (enriched-insert-indentation)
- (if enriched-verbose (message "Filling paragraphs..."))
- (fill-region (point-min) (point-max))))
- (if enriched-verbose (message nil))
+ ;; Indent or fill the buffer
+ (cond (file-width ; File was filled to this width
+ (setq fill-column file-width)
+ (if enriched-verbose (message "Indenting..."))
+ (enriched-insert-indentation))
+ (t ; File was not filled.
+ (if enriched-verbose (message "Filling paragraphs..."))
+ (fill-region (point-min) (point-max))))
+ (if enriched-verbose (message nil)))
(point-max))))
(defun enriched-next-annotation ()
"Find and return next text/enriched annotation.
-Any \"<<\" strings encountered are coverted to \"<\".
+Any \"<<\" strings encountered are converted to \"<\".
Return value is \(begin end name positive-p), or nil if none was found."
(while (and (search-forward "<" nil 1)
(progn (goto-char (match-beginning 0))
(delete-char 1)
;; A single < that does not start an annotation is an error,
;; which we note and then ignore.
- (message (format "Warning: malformed annotation in file at %s"
- (1- (point))))))
+ (message "Warning: malformed annotation in file at %s"
+ (1- (point)))))
(if (not (eobp))
(let* ((beg (match-beginning 0))
(end (match-end 0))
- (name (downcase (buffer-substring
+ (name (downcase (buffer-substring
(match-beginning 2) (match-end 2))))
(pos (not (match-beginning 1))))
(list beg end name pos))))
(if (looking-at "^\n")
(delete-char 1)))
-(defun enriched-decode-foreground (from to color)
- (let ((face (intern (concat "fg:" color))))
- (cond ((internal-find-face face))
- ((and window-system (facemenu-get-face face)))
- (window-system
- (message "Warning: color \"%s\" is not defined." color))
- ((make-face face)
- (message "Warning: Color \"%s\" can't be displayed." color)))
- (list from to 'face face)))
-
-(defun enriched-decode-background (from to color)
- (let ((face (intern (concat "bg:" color))))
- (cond ((internal-find-face face))
- ((and window-system (facemenu-get-face face)))
- (window-system
- (message "Warning: color \"%s\" is not defined." color))
- ((make-face face)
- (message "Warning: Color \"%s\" can't be displayed." color)))
- (list from to 'face face)))
+(defun enriched-decode-foreground (from to &optional color)
+ (if color
+ (list from to 'face (list ':foreground color))
+ (message "Warning: no color specified for <x-color>")
+ nil))
+
+(defun enriched-decode-background (from to &optional color)
+ (if color
+ (list from to 'face (list ':background color))
+ (message "Warning: no color specified for <x-bg-color>")
+ nil))
+\f
+;;; Handling the `display' property.
+
+
+(defun enriched-handle-display-prop (old new)
+ "Return a list of annotations for a change in the `display' property.
+OLD is the old value of the property, NEW is the new value. Value
+is a list `(CLOSE OPEN)', where CLOSE is a list of annotations to
+close and OPEN a list of annotations to open. Each of these lists
+has the form `(ANNOTATION PARAM ...)'."
+ (let ((annotation "x-display")
+ (param (prin1-to-string (or old new))))
+ (if (null old)
+ (cons nil (list (list annotation param)))
+ (cons (list (list annotation param)) nil))))
+
+(defun enriched-decode-display-prop (start end &optional param)
+ "Decode a `display' property for text between START and END.
+PARAM is a `<param>' found for the property.
+Value is a list `(START END SYMBOL VALUE)' with START and END denoting
+the range of text to assign text property SYMBOL with value VALUE "
+ (let ((prop (when (stringp param)
+ (condition-case ()
+ (car (read-from-string param))
+ (error nil)))))
+ (unless prop
+ (message "Warning: invalid <x-display> parameter %s" param))
+ (list start end 'display prop)))
;;; enriched.el ends here
HCoop / bpt / emacs.git / blobdiff