Commits

Anonymous committed 879da3d

2001-12-29 Steve Youngs <youngs@xemacs.org>

* package-info.in: (provides): Update to include all provides.

2001-12-28 Steve Youngs <youngs@xemacs.org>

* rtf-support.el: New file.

* Makefile (ELCS): Add rtf-support.elc

Comments (0)

Files changed (4)

+2001-12-29  Steve Youngs  <youngs@xemacs.org>
+
+	* package-info.in: (provides): Update to include all provides.
+
+2001-12-28  Steve Youngs  <youngs@xemacs.org>
+
+	* rtf-support.el: New file.
+
+	* Makefile (ELCS): Add rtf-support.elc
+
 2001-07-18  Charles G Waldman  <cgw@xemacs.org>
+
         * hexl.el (hexlify-buffer):
         * hexl.el (dehexlify-buffer): Check whether buffer-file-system
         is bound.
 
 # This XEmacs package contains independent single file lisp packages
 
-VERSION = 1.32
+VERSION = 1.33
 AUTHOR_VERSION =
 MAINTAINER = XEmacs Development Team <xemacs-beta@xemacs.org>
 PACKAGE = text-modes
 	image-mode.elc iso-acc.elc iso-ascii.elc iso-cvt.elc iso-insert.elc \
 	iso-swed.elc nroff-mode.elc scribe.elc swedish.elc tabify.elc \
 	underline.elc whitespace-mode.elc winmgr-mode.elc ws-mode.elc \
-	xpm-mode.elc xrdb-mode.elc ansi-color.elc
+	xpm-mode.elc xrdb-mode.elc ansi-color.elc rtf-support.elc
 
 include ../../XEmacs.rules
 
    filename FILENAME
    md5sum MD5SUM
    size SIZE
-   provides (autoinsert crontab-edit filladapt fold-isearch folding image-mode iso-acc iso-ascii iso-cvt iso-insert iso-swed swedish tabify whitespace-mode winmgr-mode xpm-mode xrdb-mode)
+   provides (ansi-color autoinsert crontab-edit filladapt flyspell folding fold-isearch hexl htmlize image-mode iso-acc iso-ascii iso-cvt iso-insert iso-swed rft-support swedish tabify whitespace-mode winmgr-mode xpm-mode xrdb-mode)
    requires (REQUIRES)
    type regular
 ))
+;;; rtf-support.el --- MS Rich Text Format support functions
+
+;; Copyright (C) 2000 Alastair J. Houghton
+
+;; Authors:    1999-2001 Alastair J. Houghton <ajhoughton@lineone.net>
+;; Keywords:   RTF Microsoft Windows NT
+;; Version:    1.4
+
+;; This file is part of XEmacs
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;; If you want to actually *use* RTF, you probably want to take a look
+;; at the functions `rtf-clip-region', `rtf-clip-buffer',
+;; `rtf-export-region' and `rtf-export-buffer' or if you're more interested
+;; in how it all works, `rtf-spool-region' and `rtf-spool-buffer'.
+
+;; Some people like to rebind their global keymap so that they can do
+;; rtf-clip-region directly from the keyboard.  An example follows:
+;;
+;;   (require 'rtf-support)
+;;
+;;   (define-key global-map '(control meta insert) 'rtf-clip-region)
+;;
+;; Note that the rtf-clip functions do *not* place things into the
+;; XEmacs kill ring, just onto the clipboard.  XEmacs makes it appear as
+;; if things on the clipboard are at the top of the kill ring via the
+;; `interprogram-paste-function'.  
+;;
+;; It's probably best to treat all of these functions the way you'd
+;; treat `htmlize' or `ps-spool-*'; whilst they probably are quick enough
+;; to replace kill/yank/copy for day-to-day use, they do perform a fair bit
+;; of processing and could theoretically take a long time or use up a lot
+;; of memory executing...
+
+;; Requires
+(require 'cl)
+
+(defconst rtf-version "1.4"
+  "RTF-support version number.")
+
+;;; Customisation support     
+
+;;;###autoload
+(defgroup rtf nil
+  "Support RTF selections and spooling of RTF to a buffer."
+  :group 'wp
+  :tag "RTF")
+
+;; This says whether to untabify the text before changing it to RTF
+(defcustom rtf-untabify-p t
+  "Set this to t to untabify the text before changing it to RTF."
+  :type 'boolean
+  :group 'rtf)
+
+(defcustom rtf-gen-ruler-p nil
+  "Set this to t to generate a set of RTF tabstops.
+This is intended for RTF readers that cannot handle character-based tabs
+properly (e.g. Microsoft Word). Note that this feature uses on-screen
+character metrics, so tabstops generated like this tend to be somewhat
+inaccurate.  It is usually better to untabify the text by setting
+`rtf-untabify-p' rather than using this feature."
+  :type 'boolean
+  :group 'rtf)
+
+(defcustom rtf-create-colours nil
+  "Non-nil causes RTF output to contain new colours.
+This is for compatibility with RTF readers that do not expect anything
+but the standard set of colours (e.g. Microsoft Word prior to Word 2000).
+If new colours are not being created, face colours are best-matched with
+those in the default colour table `rtf-default-colour-table' using a
+Euclidean distance metric."
+  :type 'boolean
+  :group 'rtf)
+
+;; This is the default colour table for the RTF output.  It is set-up the
+;; same way as Microsoft Word's default colour table, which means that
+;; the colours won't cause too much bother.
+(defcustom rtf-default-colour-table '((nil           . 0);; Auto
+				      ((0 0 0)       . 1);; Black
+				      ((0 0 255)     . 2);; Blue
+				      ((0 255 255)   . 3);; Cyan
+				      ((0 255 0)     . 4);; Green
+				      ((255 0 255)   . 5);; Magenta
+				      ((255 0 0)     . 6);; Red
+				      ((255 255 0)   . 7);; Yellow
+				      ((255 255 255) . 8);; White
+				      ((0 0 128)     . 9);; Dark Blue
+				      ((0 128 128)   . 10);; Dark Cyan
+				      ((0 128 0)     . 11);; Dark Green
+				      ((128 0 128)   . 12);; Dark Magenta
+				      ((128 0 0)     . 13);; Dark Red
+				      ((128 128 0)   . 14);; Dark Yellow
+				      ((128 128 128) . 15);; Grey
+				      ((192 192 192) . 16));; Light Grey
+  "The default colour table to use in RTF output.
+This is the palette of colours that is used when rtf-create-colours is nil;
+by default it matches the standard set used in Microsoft Word.
+
+It is only used when `rtf-create-colours' is nil, in which case Emacs face
+colours are matched with available palette colours by minimising the
+Euclidean distance between the selected palette colour and the face colour.
+
+Ideally, the indices should be unique, although that isn't enforced here
+because it's possible that someone might find a use for non-unique indices
+(in conjunction with the various broken programs that are about)."
+  :type '(repeat rtf-color-table-entry)
+  :group 'rtf)
+
+(define-widget 'rtf-color-table-entry 'default
+  "Edit an RTF colour table entry."
+  :format "%v"
+  :value '(nil . 0)
+  :value-create 'rtf-color-table-value-create
+  :value-delete 'widget-children-value-delete
+  :value-get 'rtf-color-table-value-get
+  :value-set 'rtf-color-table-value-set
+  :match '(lambda (widget value) t)
+  :validate 'widget-children-validate
+  :convert-widget 'widget-value-convert-widget)
+
+(defun rtf-color-table-value-create (widget)
+  "Create the components of an rtf-color-table-entry widget."
+  (let ((value (widget-get widget :value))
+	index color)
+    (setq index (widget-create-child-value widget
+					   '(integer
+					     :tag "Index"
+					     :size 6)
+					   (cdr value)))
+    (insert ?\ )
+    (setq color (widget-create-child-value widget
+					   '(rtf-color
+					     :tag "Color")
+					   (car value)))
+    (insert ?\n)
+    (widget-put widget :children (list index color))
+    ))
+
+(defun rtf-color-table-value-get (widget)
+  "Retrieve the value of an rtf-color-table-entry widget."
+  (let ((children (widget-get widget :children)))
+    (if children
+	(cons (widget-value (cadr children))
+	      (widget-value (car children)))
+      (widget-get widget :value))))
+
+(defun rtf-color-table-value-set (widget value)
+  "Set the value of an rtf-color-table-entry widget."
+  (let ((children (widget-get widget :children)))
+    (if children
+	(progn
+	  (widget-value-set (car children) (cdr value))
+	  (widget-value-set (cadr children) (car value))))))
+
+(define-widget 'rtf-color 'editable-field
+  "Choose a color, either (R G B) or auto (with sample)."
+  :format "%{%t%}: (%{  %}) %v"
+  :size 15
+  :tag "Color"
+  :value nil
+  :sample-face-get 'rtf-color-sample-face-get
+  :notify 'rtf-color-notify
+  :action 'rtf-color-action
+  :error "Must be an RGB triple (R G B), or auto."
+  :validate 'rtf-color-validate
+  :match 'rtf-color-match
+  :value-to-internal 'rtf-color-value-to-internal
+  :value-to-external 'rtf-color-value-to-external)
+
+(defun rtf-color-as-string (color)
+  "Get a color as a string."
+  (if (and color
+	   (not (eq color 'rtf-invalid-color)))
+      (format "#%2.2X%2.2X%2.2X" (car color) (cadr color) (caddr color))
+    "#000000"))
+
+(defun rtf-color-sample-face-get (widget)
+  "Retrieve the sample face."
+  (or (widget-get widget :sample-face)
+      (let ((color (widget-value widget))
+	    (face (make-face (gensym "sample-face-") nil t)))
+	(widget-put widget :sample-face face)
+	(if (rtf-color-match widget color)
+	    (set-face-background face (rtf-color-as-string color))
+	  (set-face-background face "#000000"))
+	face)))
+
+(defun rtf-color-action (widget &optional event)
+  "Prompt for a colour."
+  (let* ((tag (widget-apply widget :menu-tag-get))
+	 (answer (read-string (concat tag ": ")
+			      (rtf-color-value-to-internal
+			       widget
+			       (widget-value widget)))))
+    (unless (zerop (length answer))
+      (widget-value-set widget (rtf-color-value-to-external widget answer))
+      (widget-setup)
+      (widget-apply widget :notify widget event))))
+
+(defun rtf-color-notify (widget child &optional event)
+  "Update the sample, and notify the parent."
+  (let* ((face (widget-apply widget :sample-face-get))
+	 (color (widget-value widget)))
+    (if (rtf-color-match widget color)
+	(set-face-background face (rtf-color-as-string color))
+      (set-face-background face "#000000"))
+    (widget-default-notify widget child event)))
+
+(defun rtf-color-validate (widget)
+  "Validate this widget's value."
+  (let ((color (widget-value widget)))
+    (unless (rtf-color-match widget color)
+      widget)))
+
+(defun rtf-color-match (widget value)
+  "Validate this value."
+  (and (not (eq value 'rtf-invalid-color))
+       (or (not value)
+	   (and (listp value)
+		(eq (length value) 3)))))
+
+(defun rtf-color-value-to-internal (widget value)
+  "Convert to internal representation (string)."
+  (cond
+   ((eq value 'rtf-invalid-color)
+    "auto")
+   (value
+    (format "(%d %d %d)" (car value) (cadr value) (caddr value)))
+   (t
+    "auto")))
+
+(defun rtf-color-value-to-external (widget value)
+  "Convert to external representation."
+  (unless (equal value "auto")
+    (let ((val (condition-case nil
+		   (read value)
+		 (error nil))))
+      (if (and (listp val)
+	       (every '(lambda (x)
+			 (and (integerp x)
+			      (<= x 255)
+			      (>= x 0)))
+		      val))
+	  val
+	'rtf-invalid-color))
+    ))
+
+;;; Code proper:
+
+;; This is the clipboard format ID
+(defvar rtf-data-type nil
+  "Contains the window-system data type for RTF.")
+
+(unless rtf-data-type
+  (setq rtf-data-type (register-selection-data-type "Rich Text Format")))
+
+;; This function makes a string safe for inclusion in an RTF file
+(defun rtf-safe (string)
+  "Return a valid RTF string with the textual meaning of `string'.
+This function makes various special characters safe by escaping them."
+  (replace-in-string string "[{}\\\\]" "\\\\\\&" nil))
+
+(defun rtf-map-chars (string)
+  "Map some characters in an RTF string."
+  (replace-in-string (replace-in-string (rtf-safe string) "\t" "\\tab" t)
+		     "\n" "\\par\n" t)) 
+
+(defun rtf-map-colour (emacs-colour)
+  "Convert an Emacs colour triple to a more suitable form for RTF."
+  (list
+   (max (min (/ (nth 0 emacs-colour) 256) 255) 0)
+   (max (min (/ (nth 1 emacs-colour) 256) 255) 0)
+   (max (min (/ (nth 2 emacs-colour) 256) 255) 0)))
+
+(defun rtf-match-colour (colour colours best-match)
+  "Find a colour in the colours list.
+If `best-match' is non-nil, it matches the closest colour, otherwise
+it performs an exact match."
+  (if best-match
+      (let (current
+	    curcol
+	    (bestcol nil)
+	    (bestdist nil)
+	    dist)
+	;; Remember to skip the "auto" colour
+	(setq current (cdr colours))
+	(while current
+	  (setq curcol (car current))
+	  (setq current (cdr current))
+	  (let ((rd (- (nth 0 colour) (nth 0 (car curcol))))
+		(gd (- (nth 1 colour) (nth 1 (car curcol))))
+		(bd (- (nth 2 colour) (nth 2 (car curcol)))))
+	    (setq dist (sqrt (+ (* rd rd) (* gd gd) (* bd bd)))))
+	  (if (or (not bestdist) (< dist bestdist))
+	      (progn
+		(setq bestdist dist)
+		(setq bestcol (cdr curcol)))))
+	bestcol)
+    (cdr (assoc colour colours))))
+
+;; This function generates a ruler
+(defun rtf-ruler (tab-twips nstops)
+  "Generate the RTF for a set of tab-stops, starting at the left margin,
+separated by `tab-twips' twips, with `nstops' stops."
+  (let ((result nil)
+	(stops nstops)
+	(pos 0))
+    (while (> stops 0)
+      (setq stops (- stops 1))
+      (setq pos (truncate (+ pos tab-twips)))
+      (setq result (concat result "\\tx" (number-to-string pos))))
+    result)
+  )
+
+;; This function shamelessly based upon Hrvoje's htmlize-faces-in-buffer
+;; from htmlize.el
+(defun rtf-faces-in-buffer ()
+  "Return a list of the faces actually used by extents in the current buffer."
+  (let (faces)
+    (map-extents (lambda (extent ignored)
+		   (let ((face (extent-face extent)))
+		     (when (consp face)
+		       (setq face (car face)))
+		     (when (find-face face)
+		       (pushnew face faces)))
+		   nil)
+		 nil nil nil nil nil 'face)
+    (pushnew 'default faces)))
+
+
+;; This function takes a region and generates RTF in the specified buffer
+
+;;;###autoload
+(defun rtf-spool-region (start end &optional dont-fontify)
+  "Spool a buffer as Microsoft Rich Text Format text.
+Like `ps-spool-region', although the rtf-support code doesn't keep
+track of spooled regions to despool (because RTF isn't useful for
+printing). Returns the buffer containing the RTF."
+  (interactive "r")
+  (when (and font-lock-mode (not dont-fontify))
+    (font-lock-fontify-buffer))
+  
+  ;; Swap if necessary
+  (if (< end start)
+      (let ((tmp start))
+	(setq start end)
+	(setq end tmp)))
+  
+  ;; Create the new buffer
+  (let ((rtf-buf (generate-new-buffer "*rtf*"))
+	(tmp-buf nil)
+	old-buf)
+    (save-excursion
+      (message "rtf-spool-region: building header...")
+      
+      ;; Build the RTF header first
+      (insert-string "{\\rtf1\\ansi" rtf-buf)
+      
+      ;; Build the font table, colour table and stylesheet
+      (let ((fonts nil)
+	    (colours rtf-default-colour-table)
+	    (styles nil)
+	    (fnum 0) (cnum 16) (snum 0)
+	    (font nil) (forecolour nil) (backcolour nil)
+	    (style nil) (extstyle nil)
+	    (faces-list (rtf-faces-in-buffer))
+	    (style-map (make-hash-table :test 'equal))
+	    (tab-twips 720)
+	    (style-start nil))
+	
+	;; Enumerate the faces, breaking out lists
+	(mapc '(lambda (cur-face)
+		 ;; Extract font information
+		 (setq font (font-name (face-property cur-face 'font)))
+		 (setq font (split-string font ":"))
+		 (setq font (list (nth 0 font)
+				  (nth 1 font)
+				  (nth 3 font)
+				  (if (length (nth 2 font))
+				      (string-to-number (nth 2 font))
+				    10)))
+		   
+		 ;; Make a new font if necessary
+		 (unless (assoc (nth 0 font) fonts)
+		   (setq fnum (+ fnum 1))
+		   (setq fonts (append fonts (list (cons
+						    (nth 0 font) fnum)))))
+
+		 ;; Make new colours if necessary
+		 (setq forecolour (rtf-map-colour
+				   (color-rgb-components
+				    (face-property cur-face 'foreground))))
+		 (setq backcolour (rtf-map-colour
+				   (color-rgb-components
+				    (face-property cur-face 'background))))
+
+		 (if rtf-create-colours
+		     (progn
+		       (unless (assoc forecolour colours)
+			 (setq cnum (+ cnum 1))
+			 (setq colours (append colours
+					       (list
+						(cons forecolour cnum)))))
+		
+		       (unless (assoc backcolour colours)
+			 (setq cnum (+ cnum 1))
+			 (setq colours (append colours
+					       (list
+						(cons backcolour cnum)))))
+		       ))
+	  
+		 ;; Sort-out bold, underlined, etc...
+		 (setq extstyle nil)
+		 (let ((font-type (nth 1 font)))
+		   (if (string-match "Bold" font-type)
+		       (setq extstyle (concat "\\b" extstyle)))
+		   (if (string-match "Italic" font-type)
+		       (setq extstyle (concat "\\i" extstyle)))
+		   (if (face-underline-p cur-face)
+		       (setq extstyle (concat "\\ul" extstyle)))
+		   )
+	     
+		 ;; Make a new style for this face
+		 (setq style (list (format "(Emacs) %s" cur-face)
+				   (cdr (assoc (nth 0 font) fonts))
+				   (nth 3 font)
+				   (rtf-match-colour forecolour colours
+						     (not rtf-create-colours))
+				   (rtf-match-colour backcolour colours
+						     (not rtf-create-colours))
+				   extstyle
+				   cur-face))
+
+		 ;; If this was the default face, work-out how big a tab is
+		 (unless rtf-untabify-p
+		   (if (equal (nth 0 style) "(Emacs) default")
+		       (let ((fwidth (font-instance-width
+				      (specifier-instance
+				       (face-property cur-face 'font)))))
+			 (setq tab-twips (* (* fwidth 15) tab-width))
+			 )))
+
+		 (setq snum (+ snum 1))
+		 (setq styles (append styles (list (cons style snum)))))
+	      faces-list)
+
+	;; OK - emit the font table
+	(insert-string "{\\fonttbl" rtf-buf)
+
+	(mapc '(lambda (font)
+		 (insert-string (concat "\\f" (number-to-string (cdr font))
+					"\\fmodern " (car font) ";") rtf-buf))
+	      fonts)
+
+	;; Now emit the colour table
+	(insert-string "}\n{\\colortbl;" rtf-buf)
+
+	(mapc '(lambda (colour)
+		 (if (car colour)
+		     (insert-string (concat
+				     "\\red" (number-to-string
+					      (first (car colour)))
+				     "\\green" (number-to-string
+						(second (car colour)))
+				     "\\blue" (number-to-string
+					       (third (car colour)))
+				     ";") rtf-buf)))
+	      colours)
+			   
+	;; Finally do the stylesheet
+	(insert-string "}\n{\\stylesheet" rtf-buf)
+	(setq style-start (point rtf-buf))
+	
+	(mapc
+	 '(lambda (style)
+	    (if (equal (first (car style)) "(Emacs) default")
+		(let ((cur-pos (point rtf-buf)))
+		  (goto-char style-start rtf-buf)
+		  (insert-string (concat
+				  "{\\s15"
+				  "\\plain\\f" (number-to-string
+						(second (car style)))
+				  "\\fs" (number-to-string
+					  (* (third (car style)) 2))
+				  "\\cf" (number-to-string (fourth (car style)))
+				  "\\cb" (number-to-string (fifth (car style)))
+				  "\\lang1024"
+				  (sixth (car style))
+				  (when rtf-gen-ruler-p
+				    (rtf-ruler tab-twips 30))
+				  " Emacs Text;}"
+				  "{\\*\\cs16"
+				  " \\additive"
+				  "\\f" (number-to-string
+					 (second (car style)))
+				  "\\fs" (number-to-string
+					  (* (third (car style)) 2))
+				  "\\cf" (number-to-string (fourth (car style)))
+				  "\\cb" (number-to-string (fifth (car style)))
+				  "\\lang1024"
+				  (sixth (car style))
+				  " Emacs Base Style;}") rtf-buf)
+		  (goto-char (+ cur-pos (- (point rtf-buf) style-start)) rtf-buf)
+		  (puthash nil (concat
+				"\\cs16"
+				"\\f" (number-to-string (second (car style)))
+				"\\fs" (number-to-string (* (third
+							     (car style)) 2))
+				"\\cf" (number-to-string (fourth (car style)))
+				"\\cb" (number-to-string (fifth (car style)))
+				"\\lang1024" (sixth (car style)))
+			   style-map))
+	      (insert-string (concat
+			      "{\\*\\cs" (number-to-string (+ 16 (cdr style)))
+			      " \\additive"
+			      "\\f" (number-to-string (second (car style)))
+			      "\\fs" (number-to-string (* (third (car style)) 2))
+			      "\\cf" (number-to-string (fourth (car style)))
+			      "\\cb" (number-to-string (fifth (car style)))
+			      "\\lang1024"
+			      (sixth (car style))
+			      " \\sbasedon16 "
+			      (first (car style))
+			      ";}") rtf-buf)
+	      (puthash (nth 6 (car style))
+		       (concat
+			"\\cs" (number-to-string (+ 16 (cdr style)))
+			"\\f" (number-to-string (second (car style)))
+			"\\fs" (number-to-string (* (third (car style)) 2))
+			"\\cf" (number-to-string (fourth (car style)))
+			"\\cb" (number-to-string (fifth (car style)))
+			"\\lang1024"
+			(sixth (car style)))
+		       style-map)))
+	 styles)
+	
+	;; End the header
+	(insert-string (concat "}\n{\\plain\\s15"
+			       (when rtf-gen-ruler-p
+				 (rtf-ruler tab-twips 30))
+			       "{\\cs16"
+			       (gethash nil style-map)) rtf-buf)
+
+	;; Go through all the extents writing out the text and the style changes
+	(setq old-buf (current-buffer))
+	
+	(if rtf-untabify-p
+	    (progn
+	      (setq tmp-buf (generate-new-buffer "*rtf-tmp*"))
+	      (let ((old-tab-width tab-width))
+		(set-buffer tmp-buf)
+		(setq tab-width old-tab-width)
+		(insert-buffer old-buf)
+		(map-extents '(lambda (extent arg)
+				(let ((new-extent (copy-extent extent)))
+				  (set-extent-property new-extent 'read-only nil)
+				  (insert-extent new-extent
+						 (extent-start-position extent)
+						 (extent-end-position extent)))
+				nil)
+			     old-buf)
+		(let ((start-mark (make-marker))
+		      (end-mark (make-marker)))
+		  (set-marker start-mark start)
+		  (set-marker end-mark end)
+		  (untabify (point-min) (point-max))
+		  (setq start (marker-position start-mark))
+		  (setq end (marker-position end-mark))
+		  ))))
+
+	(let ((pos start)
+	      (percent 5))
+	  (while (< pos end)
+	    (let ((next-change
+		   (or (next-single-property-change pos 'face)
+		       end))
+		  (formatting (gethash (get-text-property pos 'face)
+				       style-map)))
+	      (if formatting
+		  (insert-string (concat
+				  "{" formatting
+				  " "
+				  (rtf-map-chars (buffer-substring-no-properties
+						  pos next-change))
+				  "}")
+				 rtf-buf)
+		(insert-string (rtf-map-chars (buffer-substring-no-properties
+					       pos next-change))
+			       rtf-buf))
+	      
+	      (setq pos next-change)
+	      
+	      (let ((real-percent (/ (* 100 (- pos start)) (- end start))))
+		(when (> real-percent percent)
+		  (progn
+		    (message "rtf-spool-region: %d%% ..." percent)
+		    (setq percent (- (+ 5 real-percent) (mod real-percent 5))))))
+	      )))
+
+	(set-buffer old-buf)
+	
+	;; Delete temporary buffer
+	(if rtf-untabify-p
+	    (kill-buffer tmp-buf))
+	
+	;; End the file
+	(insert-string "\\par\n}}}" rtf-buf)
+
+	(message "rtf-spool-region: done")
+	))
+    rtf-buf
+    ))
+
+;;;###autoload
+(defun rtf-spool-buffer ()
+  "Spool the entire buffer."
+  (interactive)
+  (rtf-spool-region 1 (buffer-size)))
+
+;;; Functions users are most likely to use
+
+;;;###autoload
+(defun rtf-export (filename)
+  "Export the current document as RTF, preserving faces."
+  (interactive "FExport RTF: ")
+  (let ((rtf-buf (rtf-spool-buffer)))
+    (save-excursion
+      (set-buffer rtf-buf)
+      (write-file filename t))
+    (kill-buffer rtf-buf)))
+
+;;;###autoload
+(defun rtf-export-region (filename start end)
+  "Export the selected region as RTF, preserving faces."
+  (interactive "FExport RTF: \nr")
+  (let ((rtf-buf (rtf-spool-region start end)))
+    (save-excursion
+      (set-buffer rtf-buf)
+      (write-file filename t))
+    (kill-buffer rtf-buf)))
+
+;; The selection converter function (we only support *output* for now)
+(defun rtf-convert-to-rtf (selection type value)
+  "Convert VALUE to RTF, where VALUE is one of:
+
+* A string. The string is converted to RTF. Non-duplicable extents will
+  not be converted to RTF style changes.
+
+* A buffer. The buffer's contents are converted to RTF.
+
+* A list of the form (BUFFER START END), where BUFFER is the buffer from
+  which to convert, START and END define a region within the buffer to
+  be converted."
+  (cond ((stringp value)
+	 (let ((tmp-buf (generate-new-buffer "*rtf-tmp*")))
+	   (insert-string value tmp-buf)
+	   (rtf-convert-to-rtf selection type tmp-buf)))
+	((bufferp value)
+	 (let* ((rtf-buf (rtf-spool-buffer))
+		(text (buffer-substring-no-properties
+		       (point-min rtf-buf)
+		       (point-max rtf-buf)
+		       rtf-buf)))
+	   (kill-buffer rtf-buf)
+	   text))
+	((and (listp value)
+	      (bufferp (first value))
+	      (integer-or-marker-p (second value))
+	      (integer-or-marker-p (third value)))
+	 (let* ((start (if (integerp (second value))
+			   (second value)
+			 (marker-position (second value))))
+		(end (if (integerp (third value))
+			 (third value)
+		       (marker-position (third value))))
+		(rtf-buf (rtf-spool-region start end t))
+		(text (buffer-substring-no-properties
+		       (point-min rtf-buf) (point-max rtf-buf) rtf-buf)))
+	   (kill-buffer rtf-buf)
+	   text))
+	(t nil)
+	))
+
+;; Install the converter
+(unless (assq rtf-data-type selection-converter-out-alist)
+  (setq selection-converter-out-alist
+	(cons (cons rtf-data-type 'rtf-convert-to-rtf)
+	      selection-converter-out-alist)))
+  
+;;;###autoload
+(defun rtf-clip-buffer ()
+  "Send the entire buffer to the clipboard as Rich Text Format. The function
+also copies the buffer as ordinary text, just for consistency."
+  (interactive)
+  (let ((text (buffer-substring-no-properties)))
+    (own-selection text 'CLIPBOARD)
+    (own-selection (current-buffer) 'CLIPBOARD 'replace-existing
+		   rtf-data-type)))
+
+;;;###autoload
+(defun rtf-clip-region (start end)
+  "Send the specified region (the selection if called interactively) to the
+clipboard as Rich Text Format. The function also copies the region in ordinary
+text, just for consistency."
+  (interactive "r")
+  (let ((text (buffer-substring-no-properties start end)))
+    (own-selection text 'CLIPBOARD)
+    (own-selection (list (current-buffer) start end) 'CLIPBOARD
+		   'replace-existing rtf-data-type)))
+
+;;; Provides RTF support
+
+(provide 'rtf-support)