X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/5f7781abe9b3a10e52fd9b792ff6fa2a601aa610..930ca8e8456912a10ab89c400bdfecb32be64a22:/lisp/enriched.el diff --git a/lisp/enriched.el b/lisp/enriched.el index 8d30de3dc1..e74cb6b8ba 100644 --- a/lisp/enriched.el +++ b/lisp/enriched.el @@ -1,7 +1,8 @@ -;;; 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 +;; Copyright (c) 1994, 1995, 1996, 2002 Free Software Foundation, Inc. + +;; Author: Boris Goldowsky ;; Keywords: wp, faces ;; This file is part of GNU Emacs. @@ -10,76 +11,70 @@ ;; 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 and , which are currently not +;; standard format defined in internet RFC 1563. All standard annotations +;; are supported except for and , 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))) @@ -96,7 +91,7 @@ These are set front-sticky everywhere except at hard newlines.") (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.") @@ -104,7 +99,7 @@ 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 @@ -122,12 +117,14 @@ expression, which is evaluated to get the string to insert.") (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")) @@ -144,98 +141,78 @@ Any property that is neither on this list nor dealt with by ;;; 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}" - (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)))) @@ -298,22 +275,12 @@ the region, and the START and END of each region." (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) @@ -321,13 +288,19 @@ This is the width of the window minus `enriched-default-right-margin'." (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))) @@ -337,40 +310,52 @@ This is the width of the window minus `enriched-default-right-margin'." ;; 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 "" i "")) 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)))) ;;; @@ -380,42 +365,40 @@ One annotation each for foreground color, background color, italic, etc." ;;;###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)) @@ -425,12 +408,12 @@ Return value is \(begin end name positive-p), or nil if none was found." (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)))) @@ -448,24 +431,44 @@ Return value is \(begin end name positive-p), or nil if none was found." (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 ") + nil)) + +(defun enriched-decode-background (from to &optional color) + (if color + (list from to 'face (list ':background color)) + (message "Warning: no color specified for ") + nil)) + +;;; 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 `' 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 parameter %s" param)) + (list start end 'display prop))) ;;; enriched.el ends here