Source

text-modes / rtf-support.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
;;; 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."
;; RAS:  07/11/03
;; adding support for form feed
  (replace-in-string (replace-in-string (replace-in-string (rtf-safe string) 
                                                           "" "\\page " t) 
                                        "\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)))
		 (let ((type (console-type)))
		   (cond
		    ((eq type 'x)
		     (setq font (split-string font "-"))
		     (setq font (list (nth 2 font)
				      (nth 3 font)
				      (nth 4 font)
				      (cond
				       ((eq (nth 8 font) "*") 10)
				       ((> (length (nth 8 font)) 0)
					(/ (string-to-number (nth 8 font)) 10))
				       (t 10)))))
		    (t
		     (setq font (split-string font ":"))
		     (setq font (list (nth 0 font)
				      (nth 1 font)
				      (nth 3 font)
				      (if (> (length (nth 2 font)) 0)
					  (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)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.