1 ;;; highlight-headers.el --- highlighting message headers.
3 ;; Copyright (C) 1992, 1993, 1994, 1995, 2002 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems
6 ;; Keywords: mail, news
8 ;; This file is part of XEmacs.
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
25 ;;; Synched up with: Not in FSF.
27 ;; This code is shared by RMAIL and VM.
31 ;; message-headers the part before the colon
32 ;; message-header-contents the part after the colon
33 ;; message-highlighted-header-contents contents of "special" headers
34 ;; message-cited-text quoted text from other messages
38 ;; highlight-headers-regexp what makes a "special" header
39 ;; highlight-headers-citation-regexp matches lines of quoted text
40 ;; highlight-headers-citation-header-regexp matches headers for quoted text
42 (defgroup highlight-headers nil
43 "Fancify rfc822 documents."
47 (defgroup highlight-headers-faces nil
48 "Faces of highlighted headers."
49 :group 'highlight-headers
52 (defface message-headers '((t (:bold t)))
53 "Face used for header part before colon."
54 :group 'highlight-headers-faces)
56 (defface message-header-contents '((t (:italic t)))
57 "Face used for header part after colon."
58 :group 'highlight-headers-faces)
60 (defface message-highlighted-header-contents '((t (:italic t :bold t)))
61 "Face used for contents of \"special\" headers."
62 :group 'highlight-headers-faces)
64 (defface message-cited-text '((t (:italic t)))
65 "Face used for cited text."
66 :group 'highlight-headers-faces)
68 (defface message-url '((t (:bold t)))
70 :group 'highlight-headers-faces)
72 (defface x-face '((t (:background "white" :foreground "black")))
73 "Face used for X-Face icon."
74 :group 'highlight-headers-faces)
77 ;; (face-name 'message-addresses)
78 ;; (wrong-type-argument
79 ;; (make-face 'message-addresses)
80 ;; (or (face-differs-from-default-p 'message-addresses)
82 ;; (copy-face 'bold-italic 'message-addresses)
83 ;; (set-face-underline-p 'message-addresses
85 ;; 'message-highlighted-header-contents))))))
87 (defcustom highlight-headers-regexp "Subject[ \t]*:"
88 "*The headers whose contents should be emphasized more.
89 The contents of these headers will be displayed in the face
90 `message-highlighted-header-contents' instead of `message-header-contents'."
92 :group 'highlight-headers)
94 (defcustom highlight-headers-citation-regexp
97 '("[ \t]*[a-zA-Z0-9_]+>+" ; supercite
98 "[ \t]*[>]+" ; ">" with leading spaces
99 "[]}<>|:]+[ \t]*" ; other chars, no leading space
103 "*The pattern to match cited text.
104 Text in the body of a message which matches this will be displayed in
105 the face `message-cited-text'."
107 :group 'highlight-headers)
109 (defcustom highlight-headers-citation-header-regexp
110 (concat "^In article\\|^In message\\|"
111 "^[^ \t].*\\(writes\\|wrote\\|said\\):\n"
112 (substring highlight-headers-citation-regexp 1))
113 "*The pattern to match the prolog of a cited block.
114 Text in the body of a message which matches this will be displayed in
115 the `message-headers' face."
117 :group 'highlight-headers)
119 (defcustom highlight-headers-highlight-citation-too nil
120 "*Whether the whole citation line should go in the `message-cited-text' face.
121 If nil, the text matched by `highlight-headers-citation-regexp' is in the
122 default face, and the remainder of the line is in the message-cited-text face."
124 :group 'highlight-headers)
126 (defcustom highlight-headers-max-message-size 10000
127 "*If the message body is larger than this many chars, don't highlight it.
128 This is to prevent us from wasting time trying to fontify things like
129 uuencoded files and large digests. If this is nil, all messages will
131 :type '(choice integer
132 (const :tag "Highlight All" nil))
133 :group 'highlight-headers)
135 (defcustom highlight-headers-hack-x-face-p (featurep 'xface)
136 "*If true, then the bitmap in an X-Face header will be displayed
137 in the buffer. This assumes you have the `uncompface' and `icontopbm'
138 programs on your path."
140 :group 'highlight-headers)
142 (defcustom highlight-headers-convert-quietly nil
143 "*Non-nil inhibits the message that is normally displayed when external
144 filters are used to convert an X-Face header. This has no effect if
145 XEmacs is compiled with internal support for x-faces."
147 :group 'highlight-headers)
149 (defcustom highlight-headers-invert-x-face-data nil
150 "*If true, causes the foreground and background bits in an X-Face
151 header to be flipped before the image is displayed. If you use a
152 light foreground color on a dark background color, you probably want
153 to set this to t. This assumes that you have the `pnminvert' program
154 on your path. This doesn't presently work with internal xface support."
156 :group 'highlight-headers)
160 (defun highlight-headers (start end hack-sig)
161 "Highlight message headers between start and end.
163 message-headers the part before the colon
164 message-header-contents the part after the colon
165 message-highlighted-header-contents contents of \"special\" headers
166 message-cited-text quoted text from other messages
167 message-url URLs (WWW uniform resource locators)
171 highlight-headers-regexp what makes a \"special\" header
172 highlight-headers-citation-regexp matches lines of quoted text
173 highlight-headers-citation-header-regexp matches headers for quoted text
175 If HACK-SIG is true,then we search backward from END for something that
176 looks like the beginning of a signature block, and don't consider that a
177 part of the message (this is because signatures are often incorrectly
178 interpreted as cited text.)"
180 (let ((s start)) (setq start end end s)))
181 (let* ((too-big (and highlight-headers-max-message-size
183 highlight-headers-max-message-size)))
186 ;; delete previous highlighting
187 (map-extents (function (lambda (extent ignore)
188 (if (extent-property extent 'headers)
189 (delete-extent extent))
191 (current-buffer) start end)
195 ;; take off signature
196 (if (and hack-sig (not too-big))
199 (if (re-search-backward "\n--+ *\n" start t)
200 (if (eq (char-after (point)) ?\n)
201 (setq end (1+ (point)))
202 (setq end (point))))))
203 (narrow-to-region start end)
206 ;; narrow down to just the headers...
208 ;; If this search fails then the narrowing performed above
210 (if (re-search-forward "^$" nil t)
211 (narrow-to-region (point-min) (point)))
215 ((looking-at "^\\([^ \t\n:]+[ \t]*:\\) *\\(.*\\(\n[ \t].*\\)*\n\\)")
216 (setq hend (match-end 0))
217 (setq e (make-extent (match-beginning 1) (match-end 1)))
218 (set-extent-face e 'message-headers)
219 (set-extent-property e 'headers t)
220 (setq p (match-end 1))
222 ((and highlight-headers-hack-x-face-p
223 (save-match-data (looking-at "^X-Face: *")))
224 ;; make the whole header invisible
225 (setq e (make-extent (match-beginning 0) (match-end 0)))
226 (set-extent-property e 'invisible t)
227 (set-extent-property e 'headers t)
228 ;; now extract the xface and put it somewhere interesting
229 (let ((xface (highlight-headers-x-face-to-pixmap
233 nil ; just leave the header invisible if
234 ; we can't convert the face for some
236 (cond ((save-excursion
237 (goto-char (point-min))
238 (save-excursion (re-search-forward "^From: *"
240 (setq e (make-extent (match-end 0)
243 ;; okay, make the beginning of the invisible
244 ;; move forward to only hide the modem noise...
245 (set-extent-endpoints e
248 ;; kludge: if a zero-length extent exists at the
249 ;; starting point of an invisible extent, then
250 ;; it's invisible... even if the invisible extent
252 (setq e (make-extent (1- (match-beginning 2))
253 (match-beginning 2)))
255 (set-extent-property e 'headers t)
256 (set-extent-end-glyph e xface))
258 ;;; I don't think this is worth the effort
259 ;;; ((looking-at "\\(From\\|Resent-From\\)[ \t]*:")
260 ;;; (setq current 'message-highlighted-header-contents)
261 ;;; (goto-char (match-end 0))
262 ;;; (or (looking-at ".*(\\(.*\\))")
263 ;;; (looking-at "\\(.*\\)<")
264 ;;; (looking-at "\\(.*\\)[@%]")
265 ;;; (looking-at "\\(.*\\)"))
267 ;;; (setq e (make-extent p (match-beginning 1)))
268 ;;; (set-extent-face e current)
269 ;;; (set-extent-property e 'headers t)
270 ;;; (setq e (make-extent (match-beginning 1) (match-end 1)))
271 ;;; (set-extent-face e 'message-addresses)
272 ;;; (set-extent-property e 'headers t)
273 ;;; (setq e (make-extent (match-end 1) (point)))
274 ;;; (set-extent-face e current)
275 ;;; (set-extent-property e 'headers t)
277 ((and highlight-headers-regexp
278 (save-match-data (looking-at highlight-headers-regexp)))
279 (setq e (make-extent (match-beginning 2) (match-end 2)))
280 (set-extent-face e 'message-highlighted-header-contents)
281 (set-extent-property e 'headers t))
283 (setq e (make-extent (match-beginning 2) (match-end 2)))
284 (set-extent-face e 'message-header-contents)
285 (set-extent-property e 'headers t))
288 ;; ignore non-header field name lines
289 (t (forward-line 1)))))
291 ;; now do the body, unless it's too big....
295 (cond ((null highlight-headers-citation-regexp)
297 ((looking-at highlight-headers-citation-regexp)
298 (or highlight-headers-highlight-citation-too
299 (goto-char (match-end 0)))
302 (let ((case-fold-search nil)) ; aaaaah, unix...
303 (looking-at "^>From ")))
304 (setq current 'message-cited-text)))
305 ;;; ((or (looking-at "^In article\\|^In message")
307 ;;; "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]+[A-Z]*[]}<>|]"))
308 ;;; (setq current 'message-headers))
309 ((null highlight-headers-citation-header-regexp)
311 ((looking-at highlight-headers-citation-header-regexp)
312 (setq current 'message-headers))
313 (t (setq current nil)))
316 (forward-line 1) ; this is to put the \n in the face too
317 (setq e (make-extent p (point)))
319 (set-extent-face e current)
320 (set-extent-property e 'headers t)
327 (narrow-to-region start real-end)
328 (highlight-headers-mark-urls start real-end)))
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
334 ;;; X-Face header conversion:
336 ;;; This cache is only used if x-face conversion is done with external
337 ;;; filters. If XEmacs is compiled --with-xface, then it's better to
338 ;;; convert it twice than to suck up memory for a potentially large cache of
339 ;;; stuff that's not difficult to recreate.
340 (defvar highlight-headers-x-face-to-pixmap-cache nil)
342 (defun highlight-headers-x-face-to-pixmap (start end)
343 (let* ((string (if (stringp start) start (buffer-substring start end)))
344 (data (assoc string highlight-headers-x-face-to-pixmap-cache)))
345 (if (featurep 'xface)
346 (let ((new-face (make-glyph (concat "X-Face: " string))))
347 (set-glyph-face new-face 'x-face)
349 ;; YUCK this is the old two-external-filters-plus-a-bunch-of-lisp method
352 (setq data (cons string
354 (highlight-headers-parse-x-face-data start end)
356 (display-error c nil)
359 (setq highlight-headers-x-face-to-pixmap-cache
360 (cons data highlight-headers-x-face-to-pixmap-cache))
364 ;;; Kludge kludge kludge for displaying the bitmap in the X-Face header.
366 ;;; This depends on the following programs: icontopbm, from the pbmplus
367 ;;; toolkit (available everywhere) and uncompface, which comes with
368 ;;; several faces-related packages, and can also be had at ftp.clark.net
369 ;;; in /pub/liebman/compface.tar.Z. See also xfaces 3.*. Not needed
370 ;;; for this, but a very nice xbiff replacment.
372 (defconst highlight-headers-x-face-bitrev
375 (let* ((v (make-string 256 0))
381 (if (/= 0 (logand i (lsh 1 (- 7 j))))
382 (setq k (logior k (lsh 1 j))))
388 (defun highlight-headers-parse-x-face-data (start end)
390 (let ((b (current-buffer))
393 (or highlight-headers-convert-quietly
394 (message "Converting X-Face header to pixmap ..."))
395 (set-buffer (get-buffer-create " *x-face-tmp*"))
396 (buffer-disable-undo (current-buffer))
400 (insert-buffer-substring b start end))
401 (while (search-forward "\n" nil t)
402 (skip-chars-backward " \t\n")
404 (skip-chars-forward " \t\n")
405 (delete-region p (point)))
406 (call-process-region (point-min) (point-max) "uncompface" t t nil)
407 (goto-char (point-min))
409 (or (looking-at "0x....,0x....,0x...., *$")
410 (error "unexpected uncompface output"))
412 (setq lines (1+ lines))
414 (goto-char (point-min))
415 (insert (format "/* Format_version=1, Width=%d, Height=%d" lines lines))
416 (insert ", Depth=1, Valid_bits_per_item=16\n */\n")
419 (forward-char 56) ; 7 groups per line
422 (delete-char -1) ; take off last comma
424 ;; Ok, now we've got the format that "icontopbm" knows about.
425 (call-process-region (point-min) (point-max) "icontopbm" t t nil)
426 ;; Invert the image if the user wants us to...
427 (if highlight-headers-invert-x-face-data
428 (call-process-region (point-min) (point-max) "pnminvert" t t nil))
430 ;; If PBM is using binary mode, we're winning.
431 (goto-char (point-min))
433 (cond ((looking-at "P4\n")
435 (delete-region (point-min) (point))
437 (insert (aref highlight-headers-x-face-bitrev
440 (setq new-face (make-glyph
442 (list lines lines (prog1 (buffer-string)
444 (set-glyph-image new-face "[xface]" 'global 'tty)
445 (set-glyph-face new-face 'x-face))
447 (error "I only understand binary-format PBM...")))
448 (or highlight-headers-convert-quietly
449 (message "Converting X-Face header to pixmap ... done."))
454 ;;; "The Internet's new BBS!" -Boardwatch Magazine
455 ;;; URL support by jwz@jwz.org
457 (defcustom highlight-headers-mark-urls (string-match "XEmacs" emacs-version)
458 "*Whether to make URLs clickable in message bodies."
460 :group 'highlight-headers)
462 ;; We use browse-url for opening the URLs.
464 (defvar highlight-headers-follow-url-function 'w3-fetch "Not used.")
465 (make-obsolete-variable 'highlight-headers-follow-url-function
466 'browse-url-browser-function)
468 (defvar highlight-headers-follow-url-netscape-auto-raise t "Not used.")
469 (make-obsolete-variable
470 'highlight-headers-follow-url-netscape-auto-raise "see `browse-url-netscape'")
472 (define-obsolete-variable-alias
473 'highlight-headers-follow-url-netscape-new-window
474 'browse-url-new-window-flag)
477 (define-obsolete-function-alias
478 'highlight-headers-follow-url-netscape 'browse-url-netscape)
481 (define-obsolete-function-alias
482 'highlight-headers-follow-url-kfm 'browse-url-kde)
485 (define-obsolete-function-alias
486 'highlight-headers-follow-url-mosaic 'browse-url-mosaic)
488 (defvar highlight-headers-url-keymap
489 (let ((m (make-sparse-keymap)))
490 (set-keymap-name m 'highlight-headers-url-keymap)
491 (if (string-match "XEmacs" emacs-version)
493 (define-key m 'button2 'highlight-headers-follow-url)
498 (defun highlight-headers-follow-url (event)
500 (let* ((p (event-point event))
501 (buffer (window-buffer (event-window event)))
502 (extent (and p (extent-at p buffer 'highlight)))
506 (buffer-substring (extent-start-position extent)
507 (extent-end-position extent))))))
508 (if (and url (string-match "\\`<\\([^>]+\\)>\\'" url))
509 (setq url (concat "news:"
510 (substring url (match-beginning 1) (match-end 1)))))
516 (defconst highlight-headers-url-pattern
518 "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|s?news\\|telnet\\|mailbox\\):"
519 "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
520 "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+"
523 (defun highlight-headers-mark-urls (start end)
525 (highlight-headers-mark-urls
528 (while (re-search-forward highlight-headers-url-pattern nil t)
529 (let ((s (match-beginning 0))
532 (goto-char (match-end 0))
533 ;(skip-chars-forward "^ \t\n\r")
534 (skip-chars-backward ".?#!*()")
536 (setq extent (make-extent s e))
537 (set-extent-face extent 'bold)
538 (set-extent-property extent 'highlight t)
539 (set-extent-property extent 'headers t)
540 (set-extent-property extent 'keymap highlight-headers-url-keymap)
544 (while (re-search-forward "^Message-ID: \\(<[^>\n]+>\\)" nil t)
545 (let ((s (match-beginning 1))
548 (setq extent (make-extent s e))
549 (set-extent-face extent 'message-url)
550 (set-extent-property extent 'highlight t)
551 (set-extent-property extent 'headers t)
552 (set-extent-property extent 'keymap highlight-headers-url-keymap)))
556 (provide 'highlight-headers)