richtext.el

   1 ;;;
   2 ;;; richtext.el -- read and save files in text/richtext format
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Created: 1995/7/15
   9 ;;; Version:
  10 ;;;     $Id: richtext.el,v 3.0 1995/11/22 11:36:06 morioka Exp $
  11 ;;; Keywords: wp, faces, MIME, multimedia
  12 ;;;
  13 ;;; This file is part of GNU Emacs.
  14 ;;;
  15 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;;; it under the terms of the GNU General Public License as published by
  17 ;;; the Free Software Foundation; either version 2, or (at your option)
  18 ;;; any later version.
  19 ;;;
  20 ;;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;; GNU General Public License for more details.
  24 ;;;
  25 ;;; You should have received a copy of the GNU General Public License
  26 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  27 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  28
  29 (require 'enriched)
  30
  31
  32 ;;; @ variables
  33 ;;;
  34
  35 (defconst richtext-initial-annotation
  36   (lambda ()
  37     (format "Content-Type: text/richtext\nText-Width: %d\n\n"
  38             (enriched-text-width)))
  39   "What to insert at the start of a text/richtext file.
  40 If this is a string, it is inserted.  If it is a list, it should be a lambda
  41 expression, which is evaluated to get the string to insert.")
  42
  43 (defconst richtext-annotation-regexp
  44   "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*"
  45   "Regular expression matching richtext annotations.")
  46
  47 (defconst richtext-translations
  48   '((face          (bold-italic "bold" "italic")
  49                    (bold        "bold")
  50                    (italic      "italic")
  51                    (underline   "underline")
  52                    (fixed       "fixed")
  53                    (excerpt     "excerpt")
  54                    (default     )
  55                    (nil         enriched-encode-other-face))
  56     (invisible     (t           "comment"))
  57     (left-margin   (4           "indent"))
  58     (right-margin  (4           "indentright"))
  59     (justification (right       "flushright")
  60                    (left        "flushleft")
  61                    (full        "flushboth")
  62                    (center      "center"))
  63     ;; The following are not part of the standard:
  64     (FUNCTION      (enriched-decode-foreground "x-color")
  65                    (enriched-decode-background "x-bg-color"))
  66     (read-only     (t           "x-read-only"))
  67     (unknown       (nil         format-annotate-value))
  68 ;   (font-size     (2           "bigger")       ; unimplemented
  69 ;                  (-2          "smaller"))
  70 )
  71   "List of definitions of text/richtext annotations.
  72 See `format-annotate-region' and `format-deannotate-region' for the definition
  73 of this structure.")
  74
  75
  76 ;;; @ encoder
  77 ;;;
  78
  79 (defun richtext-encode (from to)
  80   (if enriched-verbose (message "Richtext: encoding document..."))
  81   (save-restriction
  82     (narrow-to-region from to)
  83     (delete-to-left-margin)
  84     (unjustify-region)
  85     (goto-char from)
  86     (format-replace-strings '(("<" . "<lt>")))
  87     (format-insert-annotations
  88      (format-annotate-region from (point-max) richtext-translations
  89                              'enriched-make-annotation enriched-ignore))
  90     (goto-char from)
  91     (insert (if (stringp enriched-initial-annotation)
  92                 richtext-initial-annotation
  93               (funcall richtext-initial-annotation)))
  94     (enriched-map-property-regions 'hard
  95       (lambda (v b e)
  96         (goto-char b)
  97         (if (eolp)
  98             (while (search-forward "\n" nil t)
  99               (replace-match "<nl>\n")
 100               )))
 101       (point) nil)
 102     (if enriched-verbose (message nil))
 103     ;; Return new end.
 104     (point-max)))
 105
 106
 107 ;;; @ decoder
 108 ;;;
 109
 110 (defun richtext-next-annotation ()
 111   "Find and return next text/richtext annotation.
 112 Return value is \(begin end name positive-p), or nil if none was found."
 113   (catch 'tag
 114     (while (re-search-forward richtext-annotation-regexp nil t)
 115       (let* ((beg0 (match-beginning 0))
 116              (end0 (match-end 0))
 117              (beg  (match-beginning 1))
 118              (end  (match-end 1))
 119              (name (downcase (buffer-substring
 120                               (match-beginning 3) (match-end 3))))
 121              (pos (not (match-beginning 2)))
 122              )
 123         (cond ((equal name "lt")
 124                (delete-region beg end)
 125                (goto-char beg)
 126                (insert "<")
 127                )
 128               ((equal name "comment")
 129                (if pos
 130                    (throw 'tag (list beg0 end name pos))
 131                  (throw 'tag (list beg end0 name pos))
 132                  )
 133                )
 134               (t
 135                (throw 'tag (list beg end name pos))
 136                ))
 137         ))))
 138
 139 (defun richtext-decode (from to)
 140   (if enriched-verbose (message "Richtext: decoding document..."))
 141   (save-excursion
 142     (save-restriction
 143       (narrow-to-region from to)
 144       (goto-char from)
 145       (let ((file-width (enriched-get-file-width))
 146             (use-hard-newlines t) pc nc)
 147         (enriched-remove-header)
 148
 149         (goto-char from)
 150         (while (re-search-forward "\n\n+" nil t)
 151           (replace-match "\n")
 152           )
 153
 154         ;; Deal with newlines
 155         (goto-char from)
 156         (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t)
 157           (replace-match "\n")
 158           (put-text-property (match-beginning 0) (point) 'hard t)
 159           (put-text-property (match-beginning 0) (point) 'front-sticky nil)
 160           )
 161
 162         ;; Translate annotations
 163         (format-deannotate-region from (point-max) richtext-translations
 164                                   'richtext-next-annotation)
 165
 166         ;; Fill paragraphs
 167         (if (or (and file-width         ; possible reasons not to fill:
 168                      (= file-width (enriched-text-width))) ; correct wd.
 169                 (null enriched-fill-after-visiting) ; never fill
 170                 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
 171                      (not (y-or-n-p "Re-fill for current display width? "))))
 172             ;; Minimally, we have to insert indentation and justification.
 173             (enriched-insert-indentation)
 174           (if enriched-verbose (message "Filling paragraphs..."))
 175           (fill-region (point-min) (point-max))))
 176       (if enriched-verbose (message nil))
 177       (point-max))))
 178
 179
 180 ;;; @ end
 181 ;;;
 182
 183 (provide 'richtext)