richtext.el

   1 ;;;
   2 ;;; richtext.el -- read and save files in text/richtext format
   3 ;;;
   4 ;;; $Id: richtext.el,v 2.1 1995/07/17 22:59:10 morioka Exp $
   5 ;;;
   6
   7 (require 'enriched)
   8
   9
  10 ;;; @ variables
  11 ;;;
  12
  13 (defconst richtext-initial-annotation
  14   (lambda ()
  15     (format "Content-Type: text/richtext\nText-Width: %d\n\n"
  16             (enriched-text-width)))
  17   "What to insert at the start of a text/richtext file.
  18 If this is a string, it is inserted.  If it is a list, it should be a lambda
  19 expression, which is evaluated to get the string to insert.")
  20
  21 (defconst richtext-annotation-regexp
  22   "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*"
  23   "Regular expression matching richtext annotations.")
  24
  25 (defconst richtext-translations
  26   '((face          (bold-italic "bold" "italic")
  27                    (bold        "bold")
  28                    (italic      "italic")
  29                    (underline   "underline")
  30                    (fixed       "fixed")
  31                    (excerpt     "excerpt")
  32                    (default     )
  33                    (nil         enriched-encode-other-face))
  34     (invisible     (t           "comment"))
  35     (left-margin   (4           "indent"))
  36     (right-margin  (4           "indentright"))
  37     (justification (right       "flushright")
  38                    (left        "flushleft")
  39                    (full        "flushboth")
  40                    (center      "center"))
  41     ;; The following are not part of the standard:
  42     (FUNCTION      (enriched-decode-foreground "x-color")
  43                    (enriched-decode-background "x-bg-color"))
  44     (read-only     (t           "x-read-only"))
  45     (unknown       (nil         format-annotate-value))
  46 ;   (font-size     (2           "bigger")       ; unimplemented
  47 ;                  (-2          "smaller"))
  48 )
  49   "List of definitions of text/richtext annotations.
  50 See `format-annotate-region' and `format-deannotate-region' for the definition
  51 of this structure.")
  52
  53
  54 ;;; @ encoder
  55 ;;;
  56
  57 (defun richtext-encode (from to)
  58   (if enriched-verbose (message "Richtext: encoding document..."))
  59   (save-restriction
  60     (narrow-to-region from to)
  61     (delete-to-left-margin)
  62     (unjustify-region)
  63     (goto-char from)
  64     (format-replace-strings '(("<" . "<lt>")))
  65     (format-insert-annotations
  66      (format-annotate-region from (point-max) richtext-translations
  67                              'enriched-make-annotation enriched-ignore))
  68     (goto-char from)
  69     (insert (if (stringp enriched-initial-annotation)
  70                 richtext-initial-annotation
  71               (funcall richtext-initial-annotation)))
  72     (enriched-map-property-regions 'hard
  73       (lambda (v b e)
  74         (goto-char b)
  75         (if (eolp)
  76             (while (search-forward "\n" nil t)
  77               (replace-match "<nl>\n")
  78               )))
  79       (point) nil)
  80     (if enriched-verbose (message nil))
  81     ;; Return new end.
  82     (point-max)))
  83
  84
  85 ;;; @ decoder
  86 ;;;
  87
  88 (defun richtext-next-annotation ()
  89   "Find and return next text/richtext annotation.
  90 Return value is \(begin end name positive-p), or nil if none was found."
  91   (catch 'tag
  92     (while (re-search-forward richtext-annotation-regexp nil t)
  93       (let* ((beg0 (match-beginning 0))
  94              (end0 (match-end 0))
  95              (beg  (match-beginning 1))
  96              (end  (match-end 1))
  97              (name (downcase (buffer-substring
  98                               (match-beginning 3) (match-end 3))))
  99              (pos (not (match-beginning 2)))
 100              )
 101         (cond ((equal name "lt")
 102                (delete-region beg end)
 103                (goto-char beg)
 104                (insert "<")
 105                )
 106               ((equal name "comment")
 107                (if pos
 108                    (throw 'tag (list beg0 end name pos))
 109                  (throw 'tag (list beg end0 name pos))
 110                  )
 111                )
 112               (t
 113                (throw 'tag (list beg end name pos))
 114                ))
 115         ))))
 116
 117 (defun richtext-decode (from to)
 118   (if enriched-verbose (message "Richtext: decoding document..."))
 119   (save-excursion
 120     (save-restriction
 121       (narrow-to-region from to)
 122       (goto-char from)
 123       (let ((file-width (enriched-get-file-width))
 124             (use-hard-newlines t) pc nc)
 125         (enriched-remove-header)
 126
 127         (goto-char from)
 128         (while (re-search-forward "\n\n+" nil t)
 129           (replace-match "\n")
 130           )
 131
 132         ;; Deal with newlines
 133         (goto-char from)
 134         (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t)
 135           (replace-match "\n")
 136           (put-text-property (match-beginning 0) (point) 'hard t)
 137           (put-text-property (match-beginning 0) (point) 'front-sticky nil)
 138           )
 139
 140         ;; Translate annotations
 141         (format-deannotate-region from (point-max) richtext-translations
 142                                   'richtext-next-annotation)
 143
 144         ;; Fill paragraphs
 145         (if (or (and file-width         ; possible reasons not to fill:
 146                      (= file-width (enriched-text-width))) ; correct wd.
 147                 (null enriched-fill-after-visiting) ; never fill
 148                 (and (eq 'ask enriched-fill-after-visiting) ; asked & declined
 149                      (not (y-or-n-p "Re-fill for current display width? "))))
 150             ;; Minimally, we have to insert indentation and justification.
 151             (enriched-insert-indentation)
 152           (if enriched-verbose (message "Filling paragraphs..."))
 153           (fill-region (point-min) (point-max))))
 154       (if enriched-verbose (message nil))
 155       (point-max))))
 156
 157
 158 ;;; @ end
 159 ;;;
 160
 161 (provide 'richtext)