X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/be010748989d2be1af4eaa5e602f4cf49d37bf26..ba976213c358271b653ae2a8fec9d09c6692a7fd:/lisp/enriched.el diff --git a/lisp/enriched.el b/lisp/enriched.el index 1358b655b1..8f4bf4f039 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. -;; Author: Boris Goldowsky +;; Copyright (c) 1994, 1995, 1996 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.") - -(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.") +(defgroup enriched nil + "Read and save files in text/enriched format" + :group 'wp) -(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 (:bold t))) + "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 (:italic t))) + "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 @@ -126,8 +121,10 @@ expression, which is evaluated to get the string to insert.") (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")) @@ -145,28 +142,28 @@ 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.") + "True if Enriched mode is in use.") (make-variable-buffer-local 'enriched-mode) +(put 'enriched-mode 'permanent-local t) (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 + "Functions to run when entering 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 ;;; @@ -176,9 +173,9 @@ The value is a list of \(VAR VALUE VAR VALUE...).") "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 +More information about Enriched mode is available in the file etc/enriched.doc in the Emacs distribution directory. Commands: @@ -200,33 +197,28 @@ Commands: (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))) + (add-to-list 'buffer-file-format 'text/enriched) ;; Save old variable values before we change them. - ;; These will be restored if we exit enriched-mode. + ;; 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) + buffer-display-table enriched-display-table) + (use-hard-newlines 1 nil) (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))) + (add-to-list 'sticky (car p)) (setq p (cdr p))) (if sticky (setq default-text-properties (plist-put default-text-properties 'front-sticky sticky)))) - (run-hooks 'enriched-mode-hooks))) + (run-hooks 'enriched-mode-hook))) (set-buffer-modified-p mod) (force-mode-line-update))) @@ -235,7 +227,7 @@ Commands: ;;; (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 +290,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) @@ -327,7 +309,13 @@ This is the width of the window minus `enriched-default-right-margin'." (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))) @@ -360,17 +348,23 @@ One annotation each for foreground color, background color, italic, etc." (defun enriched-face-ans (face) "Return annotations specifying FACE." - (cond ((string-match "^fg:" (symbol-name face)) + (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)))) + ((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)) + ((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 +374,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,8 +417,8 @@ 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)) @@ -448,24 +440,57 @@ 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) +(defun enriched-decode-foreground (from to &optional 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)) + (cond ((null color) + (message "Warning: no color specified for ")) + ((facep face)) + ((and (display-color-p) (facemenu-get-face face))) ((make-face face) - (message "Warning: Color \"%s\" can't be displayed." color))) + (message "Warning: color `%s' can't be displayed" color))) (list from to 'face face))) -(defun enriched-decode-background (from to color) +(defun enriched-decode-background (from to &optional 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)) + (cond ((null color) + (message "Warning: no color specified for ")) + ((facep face)) + ((and (display-color-p) (facemenu-get-face face))) ((make-face face) - (message "Warning: Color \"%s\" can't be displayed." color))) + (message "Warning: color `%s' can't be displayed" color))) (list from to 'face face))) + + +;;; 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))) + close open) + (if (null old) + (list nil (list annotation param)) + (list (list annotation param))))) + + +(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