From ddf439122060240263f2f23057dab53f623deb9b Mon Sep 17 00:00:00 2001 From: morioka Date: Mon, 9 Mar 1998 11:57:07 +0000 Subject: [PATCH] tm 7.28. --- Makefile | 6 +- richtext.el | 183 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tinyrich.el | 166 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 352 insertions(+), 3 deletions(-) create mode 100644 richtext.el create mode 100644 tinyrich.el diff --git a/Makefile b/Makefile index 0dcc2cc..67e057e 100644 --- a/Makefile +++ b/Makefile @@ -19,16 +19,16 @@ TLDIR19 = $(HOME)/lib/emacs19/lisp FILES = tl/README.eng tl/Makefile tl/mk-tl tl/*.el tl/doc/*.texi \ tl/Changes* -TARFILE = tl-7.01.7.tar +TARFILE = tl-7.01.8.tar elc: $(EMACS) -batch -l mk-tl -f compile-tl -install-18: +install-18: elc $(EMACS) -batch -l mk-tl -f install-tl $(TLDIR18) -install-19: +install-19: elc $(EMACS) -batch -l mk-tl -f install-tl $(TLDIR19) diff --git a/richtext.el b/richtext.el new file mode 100644 index 0000000..62da059 --- /dev/null +++ b/richtext.el @@ -0,0 +1,183 @@ +;;; +;;; richtext.el -- read and save files in text/richtext format +;;; +;;; Copyright (C) 1995 Free Software Foundation, Inc. +;;; Copyright (C) 1995 MORIOKA Tomohiko +;;; +;;; Author: MORIOKA Tomohiko +;;; Created: 1995/7/15 +;;; Version: +;;; $Id: richtext.el,v 3.0 1995/11/22 11:36:06 morioka Exp $ +;;; Keywords: wp, faces, MIME, multimedia +;;; +;;; This file is part of GNU Emacs. +;;; +;;; GNU Emacs is free software; you can redistribute it and/or modify +;;; 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. + +(require 'enriched) + + +;;; @ variables +;;; + +(defconst richtext-initial-annotation + (lambda () + (format "Content-Type: text/richtext\nText-Width: %d\n\n" + (enriched-text-width))) + "What to insert at the start of a text/richtext 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 richtext-annotation-regexp + "[ \t\n]*\\(<\\(/\\)?\\([-A-za-z0-9]+\\)>\\)[ \t\n]*" + "Regular expression matching richtext annotations.") + +(defconst richtext-translations + '((face (bold-italic "bold" "italic") + (bold "bold") + (italic "italic") + (underline "underline") + (fixed "fixed") + (excerpt "excerpt") + (default ) + (nil enriched-encode-other-face)) + (invisible (t "comment")) + (left-margin (4 "indent")) + (right-margin (4 "indentright")) + (justification (right "flushright") + (left "flushleft") + (full "flushboth") + (center "center")) + ;; The following are not part of the standard: + (FUNCTION (enriched-decode-foreground "x-color") + (enriched-decode-background "x-bg-color")) + (read-only (t "x-read-only")) + (unknown (nil format-annotate-value)) +; (font-size (2 "bigger") ; unimplemented +; (-2 "smaller")) +) + "List of definitions of text/richtext annotations. +See `format-annotate-region' and `format-deannotate-region' for the definition +of this structure.") + + +;;; @ encoder +;;; + +(defun richtext-encode (from to) + (if enriched-verbose (message "Richtext: encoding document...")) + (save-restriction + (narrow-to-region from to) + (delete-to-left-margin) + (unjustify-region) + (goto-char from) + (format-replace-strings '(("<" . ""))) + (format-insert-annotations + (format-annotate-region from (point-max) richtext-translations + 'enriched-make-annotation enriched-ignore)) + (goto-char from) + (insert (if (stringp enriched-initial-annotation) + richtext-initial-annotation + (funcall richtext-initial-annotation))) + (enriched-map-property-regions 'hard + (lambda (v b e) + (goto-char b) + (if (eolp) + (while (search-forward "\n" nil t) + (replace-match "\n") + ))) + (point) nil) + (if enriched-verbose (message nil)) + ;; Return new end. + (point-max))) + + +;;; @ decoder +;;; + +(defun richtext-next-annotation () + "Find and return next text/richtext annotation. +Return value is \(begin end name positive-p), or nil if none was found." + (catch 'tag + (while (re-search-forward richtext-annotation-regexp nil t) + (let* ((beg0 (match-beginning 0)) + (end0 (match-end 0)) + (beg (match-beginning 1)) + (end (match-end 1)) + (name (downcase (buffer-substring + (match-beginning 3) (match-end 3)))) + (pos (not (match-beginning 2))) + ) + (cond ((equal name "lt") + (delete-region beg end) + (goto-char beg) + (insert "<") + ) + ((equal name "comment") + (if pos + (throw 'tag (list beg0 end name pos)) + (throw 'tag (list beg end0 name pos)) + ) + ) + (t + (throw 'tag (list beg end name pos)) + )) + )))) + +(defun richtext-decode (from to) + (if enriched-verbose (message "Richtext: decoding document...")) + (save-excursion + (save-restriction + (narrow-to-region from to) + (goto-char from) + (let ((file-width (enriched-get-file-width)) + (use-hard-newlines t) pc nc) + (enriched-remove-header) + + (goto-char from) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + + ;; Deal with newlines + (goto-char from) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (replace-match "\n") + (put-text-property (match-beginning 0) (point) 'hard t) + (put-text-property (match-beginning 0) (point) 'front-sticky nil) + ) + + ;; Translate annotations + (format-deannotate-region from (point-max) richtext-translations + 'richtext-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)) + (point-max)))) + + +;;; @ end +;;; + +(provide 'richtext) diff --git a/tinyrich.el b/tinyrich.el new file mode 100644 index 0000000..3929205 --- /dev/null +++ b/tinyrich.el @@ -0,0 +1,166 @@ +;;; +;;; $Id: tinyrich.el,v 5.0 1995/09/20 14:45:56 morioka Exp $ +;;; +;;; by MORIOKA Tomohiko +;;; modified by YAMATE Keiichirou +;;; + +(defvar mime-viewer/face-list-for-text/enriched + (cond ((and (>= emacs-major-version 19) window-system) + '(bold italic fixed underline) + ) + ((and (boundp 'NEMACS) NEMACS) + '("bold" "italic" "underline") + ))) + +(defun enriched-decode (beg end) + (interactive "*r") + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char beg) + (while (re-search-forward "[ \t]*\\(\n+\\)[ \t]*" nil t) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (if (string= str "\n") + (replace-match " ") + (replace-match (substring str 1)) + ))) + (goto-char beg) + (let (cmd sym str (fb (point)) fe b e) + (while (re-search-forward "<\\(<\\|[^<>\n\r \t]+>\\)" nil t) + (setq b (match-beginning 0)) + (setq cmd (buffer-substring b (match-end 0))) + (if (string= cmd "<<") + (replace-match "<") + (replace-match "") + (setq cmd (downcase (substring cmd 1 (- (length cmd) 1)))) + ) + (setq sym (intern cmd)) + (cond ((eq sym 'param) + (setq b (point)) + (save-excursion + (save-restriction + (if (search-forward "" nil t) + (progn + (replace-match "") + (setq e (point)) + ) + (setq e end) + ))) + (delete-region b e) + ) + ((memq sym mime-viewer/face-list-for-text/enriched) + (setq b (point)) + (save-excursion + (save-restriction + (if (re-search-forward (concat "") nil t) + (progn + (replace-match "") + (setq e (point)) + ) + (setq e end) + ))) + (tm:set-face-region b e sym) + ))) + (goto-char (point-max)) + (if (not (eq (preceding-char) ?\n)) + (insert "\n") + ) + )))) + + +;;; @ text/richtext <-> text/enriched converter +;;; + +(defun richtext-to-enriched-region (beg end) + "Convert the region of text/richtext style to text/enriched style." + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (let (b e i) + (while (re-search-forward "[ \t]*" nil t) + (setq b (match-beginning 0)) + (delete-region b + (if (re-search-forward "[ \t]*" nil t) + (match-end 0) + (point-max) + )) + ) + (goto-char (point-min)) + (while (re-search-forward "\n\n+" nil t) + (replace-match "\n") + ) + (goto-char (point-min)) + (while (re-search-forward "[ \t\n]*[ \t\n]*" nil t) + (setq b (match-beginning 0)) + (setq e (match-end 0)) + (setq i 1) + (while (looking-at "[ \t\n]*[ \t\n]*") + (setq e (match-end 0)) + (setq i (1+ i)) + (goto-char e) + ) + (delete-region b e) + (while (>= i 0) + (insert "\n") + (setq i (1- i)) + )) + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "<<") + ) + )))) + +(defun enriched-to-richtext-region (beg end) + "Convert the region of text/enriched style to text/richtext style." + (save-excursion + (save-restriction + (goto-char beg) + (and (search-forward "text/enriched") + (replace-match "text/richtext")) + (search-forward "\n\n") + (narrow-to-region (match-end 0) end) + (let (str n) + (goto-char (point-min)) + (while (re-search-forward "\n\n+" nil t) + (setq str (buffer-substring (match-beginning 0) + (match-end 0))) + (setq n (1- (length str))) + (setq str "") + (while (> n 0) + (setq str (concat str "\n")) + (setq n (1- n)) + ) + (replace-match str) + ) + (goto-char (point-min)) + (while (search-forward "<<" nil t) + (replace-match "") + ) + )))) + + +;;; @ encoder and decoder +;;; + +(defun richtext-decode (beg end) + (save-restriction + (narrow-to-region beg end) + (richtext-to-enriched-region beg (point-max)) + (enriched-decode beg (point-max)) + )) + +;; (defun richtext-encode (beg end) +;; (save-restriction +;; (narrow-to-region beg end) +;; (enriched-encode beg (point-max)) +;; (enriched-to-richtext-region beg (point-max)) +;; )) + + +;;; @ end +;;; + +(provide 'tinyrich) -- 1.7.10.4