cgit.sxemacs.org Git - packages/blob - xemacs-packages/text-modes/rtf-support.el

   1 ;;; rtf-support.el --- MS Rich Text Format support functions
   2
   3 ;; Copyright (C) 2000 Alastair J. Houghton
   4
   5 ;; Authors:    1999-2001 Alastair J. Houghton <ajhoughton@lineone.net>
   6 ;; Keywords:   RTF Microsoft Windows NT
   7 ;; Version:    1.4
   8
   9 ;; This file is part of XEmacs
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 ;; 02111-1307, USA.
  25
  26 ;; If you want to actually *use* RTF, you probably want to take a look
  27 ;; at the functions `rtf-clip-region', `rtf-clip-buffer',
  28 ;; `rtf-export-region' and `rtf-export-buffer' or if you're more interested
  29 ;; in how it all works, `rtf-spool-region' and `rtf-spool-buffer'.
  30
  31 ;; Some people like to rebind their global keymap so that they can do
  32 ;; rtf-clip-region directly from the keyboard.  An example follows:
  33 ;;
  34 ;;   (require 'rtf-support)
  35 ;;
  36 ;;   (define-key global-map '(control meta insert) 'rtf-clip-region)
  37 ;;
  38 ;; Note that the rtf-clip functions do *not* place things into the
  39 ;; XEmacs kill ring, just onto the clipboard.  XEmacs makes it appear as
  40 ;; if things on the clipboard are at the top of the kill ring via the
  41 ;; `interprogram-paste-function'.
  42 ;;
  43 ;; It's probably best to treat all of these functions the way you'd
  44 ;; treat `htmlize' or `ps-spool-*'; whilst they probably are quick enough
  45 ;; to replace kill/yank/copy for day-to-day use, they do perform a fair bit
  46 ;; of processing and could theoretically take a long time or use up a lot
  47 ;; of memory executing...
  48
  49 ;; Requires
  50 (require 'cl)
  51
  52 (defconst rtf-version "1.4"
  53   "RTF-support version number.")
  54 \f
  55 ;;; Customisation support
  56
  57 ;;;###autoload
  58 (defgroup rtf nil
  59   "Support RTF selections and spooling of RTF to a buffer."
  60   :group 'wp
  61   :tag "RTF")
  62
  63 ;; This says whether to untabify the text before changing it to RTF
  64 (defcustom rtf-untabify-p t
  65   "Set this to t to untabify the text before changing it to RTF."
  66   :type 'boolean
  67   :group 'rtf)
  68
  69 (defcustom rtf-gen-ruler-p nil
  70   "Set this to t to generate a set of RTF tabstops.
  71 This is intended for RTF readers that cannot handle character-based tabs
  72 properly (e.g. Microsoft Word). Note that this feature uses on-screen
  73 character metrics, so tabstops generated like this tend to be somewhat
  74 inaccurate.  It is usually better to untabify the text by setting
  75 `rtf-untabify-p' rather than using this feature."
  76   :type 'boolean
  77   :group 'rtf)
  78
  79 (defcustom rtf-create-colours nil
  80   "Non-nil causes RTF output to contain new colours.
  81 This is for compatibility with RTF readers that do not expect anything
  82 but the standard set of colours (e.g. Microsoft Word prior to Word 2000).
  83 If new colours are not being created, face colours are best-matched with
  84 those in the default colour table `rtf-default-colour-table' using a
  85 Euclidean distance metric."
  86   :type 'boolean
  87   :group 'rtf)
  88
  89 ;; This is the default colour table for the RTF output.  It is set-up the
  90 ;; same way as Microsoft Word's default colour table, which means that
  91 ;; the colours won't cause too much bother.
  92 (defcustom rtf-default-colour-table '((nil           . 0);; Auto
  93                                       ((0 0 0)       . 1);; Black
  94                                       ((0 0 255)     . 2);; Blue
  95                                       ((0 255 255)   . 3);; Cyan
  96                                       ((0 255 0)     . 4);; Green
  97                                       ((255 0 255)   . 5);; Magenta
  98                                       ((255 0 0)     . 6);; Red
  99                                       ((255 255 0)   . 7);; Yellow
 100                                       ((255 255 255) . 8);; White
 101                                       ((0 0 128)     . 9);; Dark Blue
 102                                       ((0 128 128)   . 10);; Dark Cyan
 103                                       ((0 128 0)     . 11);; Dark Green
 104                                       ((128 0 128)   . 12);; Dark Magenta
 105                                       ((128 0 0)     . 13);; Dark Red
 106                                       ((128 128 0)   . 14);; Dark Yellow
 107                                       ((128 128 128) . 15);; Grey
 108                                       ((192 192 192) . 16));; Light Grey
 109   "The default colour table to use in RTF output.
 110 This is the palette of colours that is used when rtf-create-colours is nil;
 111 by default it matches the standard set used in Microsoft Word.
 112
 113 It is only used when `rtf-create-colours' is nil, in which case Emacs face
 114 colours are matched with available palette colours by minimising the
 115 Euclidean distance between the selected palette colour and the face colour.
 116
 117 Ideally, the indices should be unique, although that isn't enforced here
 118 because it's possible that someone might find a use for non-unique indices
 119 (in conjunction with the various broken programs that are about)."
 120   :type '(repeat rtf-color-table-entry)
 121   :group 'rtf)
 122
 123 (define-widget 'rtf-color-table-entry 'default
 124   "Edit an RTF colour table entry."
 125   :format "%v"
 126   :value '(nil . 0)
 127   :value-create 'rtf-color-table-value-create
 128   :value-delete 'widget-children-value-delete
 129   :value-get 'rtf-color-table-value-get
 130   :value-set 'rtf-color-table-value-set
 131   :match '(lambda (widget value) t)
 132   :validate 'widget-children-validate
 133   :convert-widget 'widget-value-convert-widget)
 134
 135 (defun rtf-color-table-value-create (widget)
 136   "Create the components of an rtf-color-table-entry widget."
 137   (let ((value (widget-get widget :value))
 138         index color)
 139     (setq index (widget-create-child-value widget
 140                                            '(integer
 141                                              :tag "Index"
 142                                              :size 6)
 143                                            (cdr value)))
 144     (insert ?\ )
 145     (setq color (widget-create-child-value widget
 146                                            '(rtf-color
 147                                              :tag "Color")
 148                                            (car value)))
 149     (insert ?\n)
 150     (widget-put widget :children (list index color))
 151     ))
 152
 153 (defun rtf-color-table-value-get (widget)
 154   "Retrieve the value of an rtf-color-table-entry widget."
 155   (let ((children (widget-get widget :children)))
 156     (if children
 157         (cons (widget-value (cadr children))
 158               (widget-value (car children)))
 159       (widget-get widget :value))))
 160
 161 (defun rtf-color-table-value-set (widget value)
 162   "Set the value of an rtf-color-table-entry widget."
 163   (let ((children (widget-get widget :children)))
 164     (if children
 165         (progn
 166           (widget-value-set (car children) (cdr value))
 167           (widget-value-set (cadr children) (car value))))))
 168
 169 (define-widget 'rtf-color 'editable-field
 170   "Choose a color, either (R G B) or auto (with sample)."
 171   :format "%{%t%}: (%{  %}) %v"
 172   :size 15
 173   :tag "Color"
 174   :value nil
 175   :sample-face-get 'rtf-color-sample-face-get
 176   :notify 'rtf-color-notify
 177   :action 'rtf-color-action
 178   :error "Must be an RGB triple (R G B), or auto."
 179   :validate 'rtf-color-validate
 180   :match 'rtf-color-match
 181   :value-to-internal 'rtf-color-value-to-internal
 182   :value-to-external 'rtf-color-value-to-external)
 183
 184 (defun rtf-color-as-string (color)
 185   "Get a color as a string."
 186   (if (and color
 187            (not (eq color 'rtf-invalid-color)))
 188       (format "#%2.2X%2.2X%2.2X" (car color) (cadr color) (caddr color))
 189     "#000000"))
 190
 191 (defun rtf-color-sample-face-get (widget)
 192   "Retrieve the sample face."
 193   (or (widget-get widget :sample-face)
 194       (let ((color (widget-value widget))
 195             (face (make-face (gensym "sample-face-") nil t)))
 196         (widget-put widget :sample-face face)
 197         (if (rtf-color-match widget color)
 198             (set-face-background face (rtf-color-as-string color))
 199           (set-face-background face "#000000"))
 200         face)))
 201
 202 (defun rtf-color-action (widget &optional event)
 203   "Prompt for a colour."
 204   (let* ((tag (widget-apply widget :menu-tag-get))
 205          (answer (read-string (concat tag ": ")
 206                               (rtf-color-value-to-internal
 207                                widget
 208                                (widget-value widget)))))
 209     (unless (zerop (length answer))
 210       (widget-value-set widget (rtf-color-value-to-external widget answer))
 211       (widget-setup)
 212       (widget-apply widget :notify widget event))))
 213
 214 (defun rtf-color-notify (widget child &optional event)
 215   "Update the sample, and notify the parent."
 216   (let* ((face (widget-apply widget :sample-face-get))
 217          (color (widget-value widget)))
 218     (if (rtf-color-match widget color)
 219         (set-face-background face (rtf-color-as-string color))
 220       (set-face-background face "#000000"))
 221     (widget-default-notify widget child event)))
 222
 223 (defun rtf-color-validate (widget)
 224   "Validate this widget's value."
 225   (let ((color (widget-value widget)))
 226     (unless (rtf-color-match widget color)
 227       widget)))
 228
 229 (defun rtf-color-match (widget value)
 230   "Validate this value."
 231   (and (not (eq value 'rtf-invalid-color))
 232        (or (not value)
 233            (and (listp value)
 234                 (eq (length value) 3)))))
 235
 236 (defun rtf-color-value-to-internal (widget value)
 237   "Convert to internal representation (string)."
 238   (cond
 239    ((eq value 'rtf-invalid-color)
 240     "auto")
 241    (value
 242     (format "(%d %d %d)" (car value) (cadr value) (caddr value)))
 243    (t
 244     "auto")))
 245
 246 (defun rtf-color-value-to-external (widget value)
 247   "Convert to external representation."
 248   (unless (equal value "auto")
 249     (let ((val (condition-case nil
 250                    (read value)
 251                  (error nil))))
 252       (if (and (listp val)
 253                (every '(lambda (x)
 254                          (and (integerp x)
 255                               (<= x 255)
 256                               (>= x 0)))
 257                       val))
 258           val
 259         'rtf-invalid-color))
 260     ))
 261 \f
 262 ;;; Code proper:
 263
 264 ;; This is the clipboard format ID
 265 (defvar rtf-data-type nil
 266   "Contains the window-system data type for RTF.")
 267
 268 (unless rtf-data-type
 269   (setq rtf-data-type (register-selection-data-type "Rich Text Format")))
 270
 271 ;; This function makes a string safe for inclusion in an RTF file
 272 (defun rtf-safe (string)
 273   "Return a valid RTF string with the textual meaning of `string'.
 274 This function makes various special characters safe by escaping them."
 275   (replace-in-string string "[{}\\\\]" "\\\\\\&" nil))
 276
 277 (defun rtf-map-chars (string)
 278   "Map some characters in an RTF string."
 279 ;; RAS:  07/11/03
 280 ;; adding support for form feed
 281   (replace-in-string (replace-in-string (replace-in-string (rtf-safe string)
 282                                                            "\f" "\\page " t)
 283                                         "\t" "\\tab" t)
 284                      "\n" "\\par\n" t))
 285
 286 (defun rtf-map-colour (emacs-colour)
 287   "Convert an Emacs colour triple to a more suitable form for RTF."
 288   (list
 289    (max (min (/ (nth 0 emacs-colour) 256) 255) 0)
 290    (max (min (/ (nth 1 emacs-colour) 256) 255) 0)
 291    (max (min (/ (nth 2 emacs-colour) 256) 255) 0)))
 292
 293 (defun rtf-match-colour (colour colours best-match)
 294   "Find a colour in the colours list.
 295 If `best-match' is non-nil, it matches the closest colour, otherwise
 296 it performs an exact match."
 297   (if best-match
 298       (let (current
 299             curcol
 300             (bestcol nil)
 301             (bestdist nil)
 302             dist)
 303         ;; Remember to skip the "auto" colour
 304         (setq current (cdr colours))
 305         (while current
 306           (setq curcol (car current))
 307           (setq current (cdr current))
 308           (let ((rd (- (nth 0 colour) (nth 0 (car curcol))))
 309                 (gd (- (nth 1 colour) (nth 1 (car curcol))))
 310                 (bd (- (nth 2 colour) (nth 2 (car curcol)))))
 311             (setq dist (sqrt (+ (* rd rd) (* gd gd) (* bd bd)))))
 312           (if (or (not bestdist) (< dist bestdist))
 313               (progn
 314                 (setq bestdist dist)
 315                 (setq bestcol (cdr curcol)))))
 316         bestcol)
 317     (cdr (assoc colour colours))))
 318
 319 ;; This function generates a ruler
 320 (defun rtf-ruler (tab-twips nstops)
 321   "Generate the RTF for a set of tab-stops, starting at the left margin,
 322 separated by `tab-twips' twips, with `nstops' stops."
 323   (let ((result nil)
 324         (stops nstops)
 325         (pos 0))
 326     (while (> stops 0)
 327       (setq stops (- stops 1))
 328       (setq pos (truncate (+ pos tab-twips)))
 329       (setq result (concat result "\\tx" (number-to-string pos))))
 330     result)
 331   )
 332
 333 ;; This function shamelessly based upon Hrvoje's htmlize-faces-in-buffer
 334 ;; from htmlize.el
 335 (defun rtf-faces-in-buffer ()
 336   "Return a list of the faces actually used by extents in the current buffer."
 337   (let (faces)
 338     (map-extents (lambda (extent ignored)
 339                    (let ((face (extent-face extent)))
 340                      (when (consp face)
 341                        (setq face (car face)))
 342                      (when (find-face face)
 343                        (pushnew face faces)))
 344                    nil)
 345                  nil nil nil nil nil 'face)
 346     (pushnew 'default faces)))
 347
 348 \f
 349 ;; This function takes a region and generates RTF in the specified buffer
 350
 351 ;;;###autoload
 352 (defun rtf-spool-region (start end &optional dont-fontify)
 353   "Spool a buffer as Microsoft Rich Text Format text.
 354 Like `ps-spool-region', although the rtf-support code doesn't keep
 355 track of spooled regions to despool (because RTF isn't useful for
 356 printing). Returns the buffer containing the RTF."
 357   (interactive "r")
 358   (when (and font-lock-mode (not dont-fontify))
 359     (font-lock-fontify-buffer))
 360
 361   ;; Swap if necessary
 362   (if (< end start)
 363       (let ((tmp start))
 364         (setq start end)
 365         (setq end tmp)))
 366
 367   ;; Create the new buffer
 368   (let ((rtf-buf (generate-new-buffer "*rtf*"))
 369         (tmp-buf nil)
 370         old-buf)
 371     (save-excursion
 372       (message "rtf-spool-region: building header...")
 373
 374       ;; Build the RTF header first
 375       (insert-string "{\\rtf1\\ansi" rtf-buf)
 376
 377       ;; Build the font table, colour table and stylesheet
 378       (let ((fonts nil)
 379             (colours rtf-default-colour-table)
 380             (styles nil)
 381             (fnum 0) (cnum 16) (snum 0)
 382             (font nil) (forecolour nil) (backcolour nil)
 383             (style nil) (extstyle nil)
 384             (faces-list (rtf-faces-in-buffer))
 385             (style-map (make-hash-table :test 'equal))
 386             (tab-twips 720)
 387             (style-start nil))
 388
 389         ;; Enumerate the faces, breaking out lists
 390         (mapc '(lambda (cur-face)
 391                  ;; Extract font information
 392                  (setq font (font-name (face-property cur-face 'font)))
 393                  (let ((type (console-type)))
 394                    (cond
 395                     ((eq type 'x)
 396                      (setq font (split-string font "-"))
 397                      (setq font (list (nth 2 font)
 398                                       (nth 3 font)
 399                                       (nth 4 font)
 400                                       (cond
 401                                        ((eq (nth 8 font) "*") 10)
 402                                        ((> (length (nth 8 font)) 0)
 403                                         (/ (string-to-number (nth 8 font)) 10))
 404                                        (t 10)))))
 405                     (t
 406                      (setq font (split-string font ":"))
 407                      (setq font (list (nth 0 font)
 408                                       (nth 1 font)
 409                                       (nth 3 font)
 410                                       (if (> (length (nth 2 font)) 0)
 411                                           (string-to-number (nth 2 font))
 412                                         10))))))
 413
 414                  ;; Make a new font if necessary
 415                  (unless (assoc (nth 0 font) fonts)
 416                    (setq fnum (+ fnum 1))
 417                    (setq fonts (append fonts (list (cons
 418                                                     (nth 0 font) fnum)))))
 419
 420                  ;; Make new colours if necessary
 421                  (setq forecolour (rtf-map-colour
 422                                    (color-rgb-components
 423                                     (face-property cur-face 'foreground))))
 424                  (setq backcolour (rtf-map-colour
 425                                    (color-rgb-components
 426                                     (face-property cur-face 'background))))
 427
 428                  (if rtf-create-colours
 429                      (progn
 430                        (unless (assoc forecolour colours)
 431                          (setq cnum (+ cnum 1))
 432                          (setq colours (append colours
 433                                                (list
 434                                                 (cons forecolour cnum)))))
 435
 436                        (unless (assoc backcolour colours)
 437                          (setq cnum (+ cnum 1))
 438                          (setq colours (append colours
 439                                                (list
 440                                                 (cons backcolour cnum)))))
 441                        ))
 442
 443                  ;; Sort-out bold, underlined, etc...
 444                  (setq extstyle nil)
 445                  (let ((font-type (nth 1 font)))
 446                    (if (string-match "Bold" font-type)
 447                        (setq extstyle (concat "\\b" extstyle)))
 448                    (if (string-match "Italic" font-type)
 449                        (setq extstyle (concat "\\i" extstyle)))
 450                    (if (face-underline-p cur-face)
 451                        (setq extstyle (concat "\\ul" extstyle)))
 452                    )
 453
 454                  ;; Make a new style for this face
 455                  (setq style (list (format "(Emacs) %s" cur-face)
 456                                    (cdr (assoc (nth 0 font) fonts))
 457                                    (nth 3 font)
 458                                    (rtf-match-colour forecolour colours
 459                                                      (not rtf-create-colours))
 460                                    (rtf-match-colour backcolour colours
 461                                                      (not rtf-create-colours))
 462                                    extstyle
 463                                    cur-face))
 464
 465                  ;; If this was the default face, work-out how big a tab is
 466                  (unless rtf-untabify-p
 467                    (if (equal (nth 0 style) "(Emacs) default")
 468                        (let ((fwidth (font-instance-width
 469                                       (specifier-instance
 470                                        (face-property cur-face 'font)))))
 471                          (setq tab-twips (* (* fwidth 15) tab-width))
 472                          )))
 473
 474                  (setq snum (+ snum 1))
 475                  (setq styles (append styles (list (cons style snum)))))
 476               faces-list)
 477
 478         ;; OK - emit the font table
 479         (insert-string "{\\fonttbl" rtf-buf)
 480
 481         (mapc '(lambda (font)
 482                  (insert-string (concat "\\f" (number-to-string (cdr font))
 483                                         "\\fmodern " (car font) ";") rtf-buf))
 484               fonts)
 485
 486         ;; Now emit the colour table
 487         (insert-string "}\n{\\colortbl;" rtf-buf)
 488
 489         (mapc '(lambda (colour)
 490                  (if (car colour)
 491                      (insert-string (concat
 492                                      "\\red" (number-to-string
 493                                               (first (car colour)))
 494                                      "\\green" (number-to-string
 495                                                 (second (car colour)))
 496                                      "\\blue" (number-to-string
 497                                                (third (car colour)))
 498                                      ";") rtf-buf)))
 499               colours)
 500
 501         ;; Finally do the stylesheet
 502         (insert-string "}\n{\\stylesheet" rtf-buf)
 503         (setq style-start (point rtf-buf))
 504
 505         (mapc
 506          '(lambda (style)
 507             (if (equal (first (car style)) "(Emacs) default")
 508                 (let ((cur-pos (point rtf-buf)))
 509                   (goto-char style-start rtf-buf)
 510                   (insert-string (concat
 511                                   "{\\s15"
 512                                   "\\plain\\f" (number-to-string
 513                                                 (second (car style)))
 514                                   "\\fs" (number-to-string
 515                                           (* (third (car style)) 2))
 516                                   "\\cf" (number-to-string (fourth (car style)))
 517                                   "\\cb" (number-to-string (fifth (car style)))
 518                                   "\\lang1024"
 519                                   (sixth (car style))
 520                                   (when rtf-gen-ruler-p
 521                                     (rtf-ruler tab-twips 30))
 522                                   " Emacs Text;}"
 523                                   "{\\*\\cs16"
 524                                   " \\additive"
 525                                   "\\f" (number-to-string
 526                                          (second (car style)))
 527                                   "\\fs" (number-to-string
 528                                           (* (third (car style)) 2))
 529                                   "\\cf" (number-to-string (fourth (car style)))
 530                                   "\\cb" (number-to-string (fifth (car style)))
 531                                   "\\lang1024"
 532                                   (sixth (car style))
 533                                   " Emacs Base Style;}") rtf-buf)
 534                   (goto-char (+ cur-pos (- (point rtf-buf) style-start)) rtf-buf)
 535                   (puthash nil (concat
 536                                 "\\cs16"
 537                                 "\\f" (number-to-string (second (car style)))
 538                                 "\\fs" (number-to-string (* (third
 539                                                              (car style)) 2))
 540                                 "\\cf" (number-to-string (fourth (car style)))
 541                                 "\\cb" (number-to-string (fifth (car style)))
 542                                 "\\lang1024" (sixth (car style)))
 543                            style-map))
 544               (insert-string (concat
 545                               "{\\*\\cs" (number-to-string (+ 16 (cdr style)))
 546                               " \\additive"
 547                               "\\f" (number-to-string (second (car style)))
 548                               "\\fs" (number-to-string (* (third (car style)) 2))
 549                               "\\cf" (number-to-string (fourth (car style)))
 550                               "\\cb" (number-to-string (fifth (car style)))
 551                               "\\lang1024"
 552                               (sixth (car style))
 553                               " \\sbasedon16 "
 554                               (first (car style))
 555                               ";}") rtf-buf)
 556               (puthash (nth 6 (car style))
 557                        (concat
 558                         "\\cs" (number-to-string (+ 16 (cdr style)))
 559                         "\\f" (number-to-string (second (car style)))
 560                         "\\fs" (number-to-string (* (third (car style)) 2))
 561                         "\\cf" (number-to-string (fourth (car style)))
 562                         "\\cb" (number-to-string (fifth (car style)))
 563                         "\\lang1024"
 564                         (sixth (car style)))
 565                        style-map)))
 566          styles)
 567
 568         ;; End the header
 569         (insert-string (concat "}\n{\\plain\\s15"
 570                                (when rtf-gen-ruler-p
 571                                  (rtf-ruler tab-twips 30))
 572                                "{\\cs16"
 573                                (gethash nil style-map)) rtf-buf)
 574
 575         ;; Go through all the extents writing out the text and the style changes
 576         (setq old-buf (current-buffer))
 577
 578         (if rtf-untabify-p
 579             (progn
 580               (setq tmp-buf (generate-new-buffer "*rtf-tmp*"))
 581               (let ((old-tab-width tab-width))
 582                 (set-buffer tmp-buf)
 583                 (setq tab-width old-tab-width)
 584                 (insert-buffer old-buf)
 585                 (map-extents '(lambda (extent arg)
 586                                 (let ((new-extent (copy-extent extent)))
 587                                   (set-extent-property new-extent 'read-only nil)
 588                                   (insert-extent new-extent
 589                                                  (extent-start-position extent)
 590                                                  (extent-end-position extent)))
 591                                 nil)
 592                              old-buf)
 593                 (let ((start-mark (make-marker))
 594                       (end-mark (make-marker)))
 595                   (set-marker start-mark start)
 596                   (set-marker end-mark end)
 597                   (untabify (point-min) (point-max))
 598                   (setq start (marker-position start-mark))
 599                   (setq end (marker-position end-mark))
 600                   ))))
 601
 602         (let ((pos start)
 603               (percent 5))
 604           (while (< pos end)
 605             (let ((next-change
 606                    (or (next-single-property-change pos 'face)
 607                        end))
 608                   (formatting (gethash (get-text-property pos 'face)
 609                                        style-map)))
 610               (if formatting
 611                   (insert-string (concat
 612                                   "{" formatting
 613                                   " "
 614                                   (rtf-map-chars (buffer-substring-no-properties
 615                                                   pos next-change))
 616                                   "}")
 617                                  rtf-buf)
 618                 (insert-string (rtf-map-chars (buffer-substring-no-properties
 619                                                pos next-change))
 620                                rtf-buf))
 621
 622               (setq pos next-change)
 623
 624               (let ((real-percent (/ (* 100 (- pos start)) (- end start))))
 625                 (when (> real-percent percent)
 626                   (progn
 627                     (message "rtf-spool-region: %d%% ..." percent)
 628                     (setq percent (- (+ 5 real-percent) (mod real-percent 5))))))
 629               )))
 630
 631         (set-buffer old-buf)
 632
 633         ;; Delete temporary buffer
 634         (if rtf-untabify-p
 635             (kill-buffer tmp-buf))
 636
 637         ;; End the file
 638         (insert-string "\\par\n}}}" rtf-buf)
 639
 640         (message "rtf-spool-region: done")
 641         ))
 642     rtf-buf
 643     ))
 644
 645 ;;;###autoload
 646 (defun rtf-spool-buffer ()
 647   "Spool the entire buffer."
 648   (interactive)
 649   (rtf-spool-region 1 (buffer-size)))
 650 \f
 651 ;;; Functions users are most likely to use
 652
 653 ;;;###autoload
 654 (defun rtf-export (filename)
 655   "Export the current document as RTF, preserving faces."
 656   (interactive "FExport RTF: ")
 657   (let ((rtf-buf (rtf-spool-buffer)))
 658     (save-excursion
 659       (set-buffer rtf-buf)
 660       (write-file filename t))
 661     (kill-buffer rtf-buf)))
 662
 663 ;;;###autoload
 664 (defun rtf-export-region (filename start end)
 665   "Export the selected region as RTF, preserving faces."
 666   (interactive "FExport RTF: \nr")
 667   (let ((rtf-buf (rtf-spool-region start end)))
 668     (save-excursion
 669       (set-buffer rtf-buf)
 670       (write-file filename t))
 671     (kill-buffer rtf-buf)))
 672
 673 ;; The selection converter function (we only support *output* for now)
 674 (defun rtf-convert-to-rtf (selection type value)
 675   "Convert VALUE to RTF, where VALUE is one of:
 676
 677 * A string. The string is converted to RTF. Non-duplicable extents will
 678   not be converted to RTF style changes.
 679
 680 * A buffer. The buffer's contents are converted to RTF.
 681
 682 * A list of the form (BUFFER START END), where BUFFER is the buffer from
 683   which to convert, START and END define a region within the buffer to
 684   be converted."
 685   (cond ((stringp value)
 686          (let ((tmp-buf (generate-new-buffer "*rtf-tmp*")))
 687            (insert-string value tmp-buf)
 688            (rtf-convert-to-rtf selection type tmp-buf)))
 689         ((bufferp value)
 690          (let* ((rtf-buf (rtf-spool-buffer))
 691                 (text (buffer-substring-no-properties
 692                        (point-min rtf-buf)
 693                        (point-max rtf-buf)
 694                        rtf-buf)))
 695            (kill-buffer rtf-buf)
 696            text))
 697         ((and (listp value)
 698               (bufferp (first value))
 699               (integer-or-marker-p (second value))
 700               (integer-or-marker-p (third value)))
 701          (let* ((start (if (integerp (second value))
 702                            (second value)
 703                          (marker-position (second value))))
 704                 (end (if (integerp (third value))
 705                          (third value)
 706                        (marker-position (third value))))
 707                 (rtf-buf (rtf-spool-region start end t))
 708                 (text (buffer-substring-no-properties
 709                        (point-min rtf-buf) (point-max rtf-buf) rtf-buf)))
 710            (kill-buffer rtf-buf)
 711            text))
 712         (t nil)
 713         ))
 714
 715 ;; Install the converter
 716 (unless (assq rtf-data-type selection-converter-out-alist)
 717   (setq selection-converter-out-alist
 718         (cons (cons rtf-data-type 'rtf-convert-to-rtf)
 719               selection-converter-out-alist)))
 720
 721 ;;;###autoload
 722 (defun rtf-clip-buffer ()
 723   "Send the entire buffer to the clipboard as Rich Text Format. The function
 724 also copies the buffer as ordinary text, just for consistency."
 725   (interactive)
 726   (let ((text (buffer-substring-no-properties)))
 727     (own-selection text 'CLIPBOARD)
 728     (own-selection (current-buffer) 'CLIPBOARD 'replace-existing
 729                    rtf-data-type)))
 730
 731 ;;;###autoload
 732 (defun rtf-clip-region (start end)
 733   "Send the specified region (the selection if called interactively) to the
 734 clipboard as Rich Text Format. The function also copies the region in ordinary
 735 text, just for consistency."
 736   (interactive "r")
 737   (let ((text (buffer-substring-no-properties start end)))
 738     (own-selection text 'CLIPBOARD)
 739     (own-selection (list (current-buffer) start end) 'CLIPBOARD
 740                    'replace-existing rtf-data-type)))
 741 \f
 742 ;;; Provides RTF support
 743
 744 (provide 'rtf-support)