Mercurial > hg > xemacs-beta

comparison lisp/utils/highlight-headers.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; highlight-headers.el --- highlighting message headers.
2
3 ;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems
5
6 ;; Keywords: mail, news
7
8 ;; This file is part of XEmacs.
9
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)
13 ;; any later version.
14
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.
19
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 Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;;; Synched up with: Not in FSF.
25
26 ;; This code is shared by RMAIL, VM, and GNUS.
27 ;;
28 ;; Faces:
29 ;;
30 ;; message-headers the part before the colon
31 ;; message-header-contents the part after the colon
32 ;; message-highlighted-header-contents contents of "special" headers
33 ;; message-cited-text quoted text from other messages
34 ;;
35 ;; Variables:
36 ;;
37 ;; highlight-headers-regexp what makes a "special" header
38 ;; highlight-headers-citation-regexp matches lines of quoted text
39 ;; highlight-headers-citation-header-regexp matches headers for quoted text
40
41 (if (find-face 'message-headers)
42 nil
43 (make-face 'message-headers)
44 (or (face-differs-from-default-p 'message-headers)
45 (copy-face 'bold 'message-headers)))
46
47 (if (find-face 'message-header-contents)
48 nil
49 (make-face 'message-header-contents)
50 (or (face-differs-from-default-p 'message-header-contents)
51 (copy-face 'italic 'message-header-contents)))
52
53 (if (find-face 'message-highlighted-header-contents)
54 nil
55 (make-face 'message-highlighted-header-contents)
56 (or (face-differs-from-default-p 'message-highlighted-header-contents)
57 (progn
58 (copy-face 'message-header-contents
59 'message-highlighted-header-contents)
60 ;; Most people seem not to like underlining, so change
61 ;; the font instead.
62 ;; (set-face-underline-p 'message-highlighted-header-contents t)
63 (or (make-face-bold 'message-highlighted-header-contents)
64 (make-face-unbold 'message-highlighted-header-contents)
65 (make-face-italic 'message-highlighted-header-contents)
66 (make-face-unitalic 'message-highlighted-header-contents))
67 )))
68
69 (if (find-face 'message-cited-text)
70 nil
71 (make-face 'message-cited-text)
72 (or (face-differs-from-default-p 'message-cited-text)
73 (copy-face 'italic 'message-cited-text)))
74
75 (if (find-face 'x-face)
76 nil
77 (make-face 'x-face)
78 (or (face-differs-from-default-p 'x-face)
79 (progn
80 (copy-face 'message-highlighted-header-contents 'x-face)
81 (set-face-background 'x-face "white")
82 (set-face-foreground 'x-face "black"))))
83
84 ;;(condition-case nil
85 ;; (face-name 'message-addresses)
86 ;; (wrong-type-argument
87 ;; (make-face 'message-addresses)
88 ;; (or (face-differs-from-default-p 'message-addresses)
89 ;; (progn
90 ;; (copy-face 'bold-italic 'message-addresses)
91 ;; (set-face-underline-p 'message-addresses
92 ;; (face-underline-p
93 ;; 'message-highlighted-header-contents))))))
94
95 (defvar highlight-headers-regexp "Subject[ \t]*:"
96 "*The headers whose contents should be emphasized more.
97 The contents of these headers will be displayed in the face
98 `message-highlighted-header-contents' instead of `message-header-contents'.")
99
100 (defvar highlight-headers-citation-regexp
101 (concat "^\\("
102 (mapconcat 'identity
103 '("[ \t]*[a-zA-Z0-9_]+>+" ; supercite
104 "[ \t]*[>]+" ; ">" with leading spaces
105 "[]}<>|:]+[ \t]*" ; other chars, no leading space
106 )
107 "\\|")
108 "\\)[ \t]*")
109 "*The pattern to match cited text.
110 Text in the body of a message which matches this will be displayed in
111 the face `message-cited-text'.")
112
113 (defvar highlight-headers-citation-header-regexp
114 (concat "^In article\\|^In message\\|"
115 "^[^ \t].*\\(writes\\|wrote\\|said\\):\n"
116 (substring highlight-headers-citation-regexp 1))
117 "*The pattern to match the prolog of a cited block.
118 Text in the body of a message which matches this will be displayed in
119 the `message-headers' face.")
120
121 (defvar highlight-headers-highlight-citation-too nil
122 "*Whether the whole citation line should go in the `mesage-cited-text' face.
123 If nil, the text matched by `highlight-headers-citation-regexp' is in the
124 default face, and the remainder of the line is in the message-cited-text face.")
125
126 (defvar 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
130 be highlighted.")
131
132 (defvar highlight-headers-hack-x-face-p (featurep 'xface)
133 "*If true, then the bitmap in an X-Face header will be displayed
134 in the buffer. This assumes you have the `uncompface' and `icontopbm'
135 programs on your path.")
136
137 (defvar highlight-headers-convert-quietly nil
138 "*Non-nil inhibits the message that is normally displayed when external
139 filters are used to convert an X-Face header. This has no affect if
140 XEmacs is compiled with internal support for x-faces.")
141
142 (defvar highlight-headers-invert-x-face-data nil
143 "*If true, causes the foreground and background bits in an X-Face
144 header to be flipped before the image is displayed. If you use a
145 light foreground color on a dark background color, you probably want
146 to set this to t. This assumes that you have the `pnminvert' program
147 on your path. This doesn't presently work with internal xface support.")
148
149
150 ;;;###autoload
151 (defun highlight-headers (start end hack-sig)
152 "Highlight message headers between start and end.
153 Faces used:
154 message-headers the part before the colon
155 message-header-contents the part after the colon
156 message-highlighted-header-contents contents of \"special\" headers
157 message-cited-text quoted text from other messages
158
159 Variables used:
160
161 highlight-headers-regexp what makes a \"special\" header
162 highlight-headers-citation-regexp matches lines of quoted text
163 highlight-headers-citation-header-regexp matches headers for quoted text
164
165 If HACK-SIG is true,then we search backward from END for something that
166 looks like the beginning of a signature block, and don't consider that a
167 part of the message (this is because signatures are often incorrectly
168 interpreted as cited text.)"
169 (if (< end start)
170 (let ((s start)) (setq start end end s)))
171 (let* ((too-big (and highlight-headers-max-message-size
172 (> (- end start)
173 highlight-headers-max-message-size)))
174 (real-end end)
175 e p hend)
176 ;; delete previous highlighting
177 (map-extents (function (lambda (extent ignore)
178 (if (extent-property extent 'headers)
179 (delete-extent extent))
180 nil))
181 (current-buffer) start end)
182 (save-excursion
183 (save-restriction
184 (widen)
185 ;; take off signature
186 (if (and hack-sig (not too-big))
187 (save-excursion
188 (goto-char end)
189 (if (re-search-backward "\n--+ *\n" start t)
190 (if (eq (char-after (point)) ?\n)
191 (setq end (1+ (point)))
192 (setq end (point))))))
193 (narrow-to-region start end)
194
195 (save-restriction
196 ;; narrow down to just the headers...
197 (goto-char start)
198 ;; If this search fails then the narrowing performed above
199 ;; is sufficient
200 (if (re-search-forward "^$" nil t)
201 (narrow-to-region (point-min) (point)))
202 (goto-char start)
203 (while (not (eobp))
204 (cond
205 ((looking-at "^\\([^ \t\n:]+[ \t]*:\\) *\\(.*\\(\n[ \t].*\\)*\n\\)")
206 (setq hend (match-end 0))
207 (setq e (make-extent (match-beginning 1) (match-end 1)))
208 (set-extent-face e 'message-headers)
209 (set-extent-property e 'headers t)
210 (setq p (match-end 1))
211 (cond
212 ((and highlight-headers-hack-x-face-p
213 (save-match-data (looking-at "^X-Face: *")))
214 ;; make the whole header invisible
215 (setq e (make-extent (match-beginning 0) (match-end 0)))
216 (set-extent-property e 'invisible t)
217 (set-extent-property e 'headers t)
218 ;; now extract the xface and put it somewhere interesting
219 (let ((xface (highlight-headers-x-face-to-pixmap
220 (match-beginning 2)
221 (match-end 2))))
222 (if (not xface)
223 nil ; just leave the header invisible if
224 ; we can't convert the face for some
225 ; reason
226 (cond ((save-excursion
227 (goto-char (point-min))
228 (save-excursion (re-search-forward "^From: *"
229 nil t)))
230 (setq e (make-extent (match-end 0)
231 (match-end 0))))
232 (t
233 ;; okay, make the beginning of the the invisible
234 ;; move forward to only hide the modem noise...
235 (set-extent-endpoints e
236 (match-beginning 2)
237 (1- (match-end 2)))
238 ;; kludge: if a zero-length extent exists at the
239 ;; starting point of an invisible extent, then
240 ;; it's invisible... even if the invisible extent
241 ;; is start-open.
242 (setq e (make-extent (1- (match-beginning 2))
243 (match-beginning 2)))
244 ))
245 (set-extent-property e 'headers t)
246 (set-extent-end-glyph e xface))
247 ))
248 ;;; I don't think this is worth the effort
249 ;;; ((looking-at "\\(From\\|Resent-From\\)[ \t]*:")
250 ;;; (setq current 'message-highlighted-header-contents)
251 ;;; (goto-char (match-end 0))
252 ;;; (or (looking-at ".*(\\(.*\\))")
253 ;;; (looking-at "\\(.*\\)<")
254 ;;; (looking-at "\\(.*\\)[@%]")
255 ;;; (looking-at "\\(.*\\)"))
256 ;;; (end-of-line)
257 ;;; (setq e (make-extent p (match-beginning 1)))
258 ;;; (set-extent-face e current)
259 ;;; (set-extent-property e 'headers t)
260 ;;; (setq e (make-extent (match-beginning 1) (match-end 1)))
261 ;;; (set-extent-face e 'message-addresses)
262 ;;; (set-extent-property e 'headers t)
263 ;;; (setq e (make-extent (match-end 1) (point)))
264 ;;; (set-extent-face e current)
265 ;;; (set-extent-property e 'headers t)
266 ;;; )
267 ((and highlight-headers-regexp
268 (save-match-data (looking-at highlight-headers-regexp)))
269 (setq e (make-extent (match-beginning 2) (match-end 2)))
270 (set-extent-face e 'message-highlighted-header-contents)
271 (set-extent-property e 'headers t))
272 (t
273 (setq e (make-extent (match-beginning 2) (match-end 2)))
274 (set-extent-face e 'message-header-contents)
275 (set-extent-property e 'headers t))
276 )
277 (goto-char hend))
278 ;; ignore non-header field name lines
279 (t (forward-line 1)))))
280
281 ;; now do the body, unless it's too big....
282 (if too-big
283 nil
284 (while (not (eobp))
285 (cond ((null highlight-headers-citation-regexp)
286 nil)
287 ((looking-at highlight-headers-citation-regexp)
288 (or highlight-headers-highlight-citation-too
289 (goto-char (match-end 0)))
290 (or (save-excursion
291 (beginning-of-line)
292 (let ((case-fold-search nil)) ; aaaaah, unix...
293 (looking-at "^>From ")))
294 (setq current 'message-cited-text)))
295 ;;; ((or (looking-at "^In article\\|^In message")
296 ;;; (looking-at
297 ;;; "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]+[A-Z]*[]}<>|]"))
298 ;;; (setq current 'message-headers))
299 ((null highlight-headers-citation-header-regexp)
300 nil)
301 ((looking-at highlight-headers-citation-header-regexp)
302 (setq current 'message-headers))
303 (t (setq current nil)))
304 (cond (current
305 (setq p (point))
306 (forward-line 1) ; this is to put the \n in the face too
307 (setq e (make-extent p (point)))
308 (forward-char -1)
309 (set-extent-face e current)
310 (set-extent-property e 'headers t)
311 ))
312 (forward-line 1)))
313 ))
314 (save-excursion
315 (save-restriction
316 (widen)
317 (narrow-to-region start real-end)
318 (highlight-headers-mark-urls start real-end)))
319 ))
320
321
322 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
323 ;;;
324 ;;; X-Face header conversion:
325
326 ;;; This cache is only used if x-face conversion is done with external
327 ;;; filters. If XEmacs is compiled --with-xface, then it's better to
328 ;;; convert it twice than to suck up memory for a potentially large cache of
329 ;;; stuff that's not difficult to recreate.
330 (defvar highlight-headers-x-face-to-pixmap-cache nil)
331
332 (defun highlight-headers-x-face-to-pixmap (start end)
333 (let* ((string (if (stringp start) start (buffer-substring start end)))
334 (data (assoc string highlight-headers-x-face-to-pixmap-cache)))
335 (if (featurep 'xface)
336 (let ((new-face (make-glyph (concat "X-Face: " string))))
337 (set-glyph-face new-face 'x-face)
338 new-face)
339 ;; YUCK this is the old two-external-filters-plus-a-bunch-of-lisp method
340 (if data
341 (cdr data)
342 (setq data (cons string
343 (condition-case c
344 (highlight-headers-parse-x-face-data start end)
345 (error
346 (display-error c nil)
347 (sit-for 2)
348 nil))))
349 (setq highlight-headers-x-face-to-pixmap-cache
350 (cons data highlight-headers-x-face-to-pixmap-cache))
351 (cdr data)))
352 ))
353
354 ;;; Kludge kludge kludge for displaying the bitmap in the X-Face header.
355
356 ;;; This depends on the following programs: icontopbm, from the pbmplus
357 ;;; toolkit (available everywhere) and uncompface, which comes with
358 ;;; several faces-related packages, and can also be had at ftp.clark.net
359 ;;; in /pub/liebman/compface.tar.Z. See also xfaces 3.*. Not needed
360 ;;; for this, but a very nice xbiff replacment.
361
362 (defconst highlight-headers-x-face-bitrev
363 (purecopy
364 (eval-when-compile
365 (let* ((v (make-string 256 0))
366 (i (1- (length v))))
367 (while (>= i 0)
368 (let ((j 7)
369 (k 0))
370 (while (>= j 0)
371 (if (/= 0 (logand i (lsh 1 (- 7 j))))
372 (setq k (logior k (lsh 1 j))))
373 (setq j (1- j)))
374 (aset v i k))
375 (setq i (1- i)))
376 v))))
377
378 (defun highlight-headers-parse-x-face-data (start end)
379 (save-excursion
380 (let ((b (current-buffer))
381 (lines 0)
382 p)
383 (or highlight-headers-convert-quietly
384 (message "Converting X-Face header to pixmap ..."))
385 (set-buffer (get-buffer-create " *x-face-tmp*"))
386 (buffer-disable-undo (current-buffer))
387 (erase-buffer)
388 (if (stringp start)
389 (insert start)
390 (insert-buffer-substring b start end))
391 (while (search-forward "\n" nil t)
392 (skip-chars-backward " \t\n")
393 (setq p (point))
394 (skip-chars-forward " \t\n")
395 (delete-region p (point)))
396 (call-process-region (point-min) (point-max) "uncompface" t t nil)
397 (goto-char (point-min))
398 (while (not (eobp))
399 (or (looking-at "0x....,0x....,0x...., *$")
400 (error "unexpected uncompface output"))
401 (forward-line 1)
402 (setq lines (1+ lines))
403 (delete-char -1))
404 (goto-char (point-min))
405 (insert (format "/* Format_version=1, Width=%d, Height=%d" lines lines))
406 (insert ", Depth=1, Valid_bits_per_item=16\n */\n")
407 (while (not (eobp))
408 (insert ?\t)
409 (forward-char 56) ; 7 groups per line
410 (insert ?\n))
411 (forward-char -1)
412 (delete-char -1) ; take off last comma
413 ;;
414 ;; Ok, now we've got the format that "icontopbm" knows about.
415 (call-process-region (point-min) (point-max) "icontopbm" t t nil)
416 ;; Invert the image if the user wants us to...
417 (if highlight-headers-invert-x-face-data
418 (call-process-region (point-min) (point-max) "pnminvert" t t nil))
419 ;;
420 ;; If PBM is using binary mode, we're winning.
421 (goto-char (point-min))
422 (let ((new-face))
423 (cond ((looking-at "P4\n")
424 (forward-line 2)
425 (delete-region (point-min) (point))
426 (while (not (eobp))
427 (insert (aref highlight-headers-x-face-bitrev
428 (following-char)))
429 (delete-char 1))
430 (setq new-face (make-glyph
431 (vector 'xbm :data
432 (list lines lines (prog1 (buffer-string)
433 (erase-buffer))))))
434 (set-glyph-image new-face "[xface]" 'global 'tty)
435 (set-glyph-face new-face 'x-face))
436 (t ; fix me
437 (error "I only understand binary-format PBM...")))
438 (or highlight-headers-convert-quietly
439 (message "Converting X-Face header to pixmap ... done."))
440 new-face)
441 )))
442
443
444 ;;; "The Internet's new BBS!" -Boardwatch Magazine
445 ;;; URL support by jwz@netscape.com
446
447 (defvar highlight-headers-mark-urls (string-match "XEmacs" emacs-version)
448 "*Whether to make URLs clickable in message bodies.")
449
450 (defvar highlight-headers-follow-url-function 'w3-fetch
451 "The function to invoke to follow a URL.
452 Possible values that work out of the box are:
453
454 'w3-fetch == Use emacs-w3
455 'highlight-headers-follow-url-netscape == Use Netscape 1.1
456 'highlight-headers-follow-url-mosaic == Use Mosaic")
457
458 (defvar highlight-headers-follow-url-netscape-auto-raise t
459 "*Whether to make Netscape auto-raise when a URL is sent to it.")
460
461 (defvar highlight-headers-follow-url-netscape-new-window nil
462 "*Whether to make Netscape create a new window when a URL is sent to it.")
463
464 ;;;###autoload
465 (defun highlight-headers-follow-url-netscape (url)
466 (message "Sending URL to Netscape...")
467 (save-excursion
468 (set-buffer (get-buffer-create "*Shell Command Output*"))
469 (erase-buffer)
470 (if (equal
471 0
472 (apply 'call-process "netscape" nil t nil
473 "-remote"
474 (nconc
475 (and (not highlight-headers-follow-url-netscape-auto-raise)
476 (list "-noraise"))
477 (list
478 (concat "openURL(" url
479 (if highlight-headers-follow-url-netscape-new-window
480 ",new-window)" ")"))))))
481 ;; it worked
482 nil
483 ;; it didn't work, so start a new Netscape process.
484 (call-process "netscape" nil 0 nil url)))
485 (message "Sending URL to Netscape... done"))
486
487 ;;;###autoload
488 (defun highlight-headers-follow-url-mosaic (url)
489 (message "Sending URL to Mosaic...")
490 (let ((pid-file "~/.mosaicpid")
491 (work-buffer " *mosaic work*")
492 (pid nil))
493 (cond ((file-readable-p pid-file)
494 (set-buffer (get-buffer-create work-buffer))
495 (erase-buffer)
496 (insert-file-contents pid-file)
497 (setq pid (int-to-string (string-to-int (buffer-string))))
498 (erase-buffer)
499 (insert "goto" ?\n)
500 (insert url ?\n)
501 (write-region (point-min) (point-max)
502 (concat "/tmp/Mosaic." pid)
503 nil 0)
504 (set-buffer-modified-p nil)
505 (kill-buffer work-buffer)))
506 (cond ((or (null pid)
507 (not (equal 0 (call-process "kill" nil nil nil "-USR1" pid))))
508 (call-process "Mosaic" nil 0 nil url))))
509 (message "Sending URL to Mosaic... done"))
510
511 (defvar highlight-headers-url-keymap
512 (let ((m (make-sparse-keymap)))
513 (set-keymap-name m 'highlight-headers-url-keymap)
514 (if (string-match "XEmacs" emacs-version)
515 (progn
516 (define-key m 'button2 'highlight-headers-follow-url)
517 ))
518 m))
519
520 ;;;###autoload
521 (defun highlight-headers-follow-url (event)
522 (interactive "e")
523 (let* ((p (event-point event))
524 (buffer (window-buffer (event-window event)))
525 (extent (and p (extent-at p buffer 'highlight)))
526 (url (and extent
527 (save-excursion
528 (set-buffer buffer)
529 (buffer-substring (extent-start-position extent)
530 (extent-end-position extent))))))
531 (if (and url (string-match "\\`<\\([^>]+\\)>\\'" url))
532 (setq url (concat "news:"
533 (substring url (match-beginning 1) (match-end 1)))))
534 (if url
535 (funcall highlight-headers-follow-url-function url)
536 (beep))))
537
538
539 (defconst highlight-headers-url-pattern
540 (concat
541 "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|s?news\\|telnet\\|mailbox\\):"
542 "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
543 "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+"
544 ))
545
546 (defun highlight-headers-mark-urls (start end)
547 (cond
548 (highlight-headers-mark-urls
549 (save-excursion
550 (goto-char start)
551 (while (re-search-forward highlight-headers-url-pattern nil t)
552 (let ((s (match-beginning 0))
553 e
554 extent)
555 (goto-char (match-end 0))
556 ;(skip-chars-forward "^ \t\n\r")
557 (skip-chars-backward ".?#!*()")
558 (setq e (point))
559 (setq extent (make-extent s e))
560 (set-extent-face extent 'bold)
561 (set-extent-property extent 'highlight t)
562 (set-extent-property extent 'headers t)
563 (set-extent-property extent 'keymap highlight-headers-url-keymap)
564 ))
565
566 (goto-char start)
567 (while (re-search-forward "^Message-ID: \\(<[^>\n]+>\\)" nil t)
568 (let ((s (match-beginning 1))
569 (e (match-end 1))
570 extent)
571 (setq extent (make-extent s e))
572 (set-extent-face extent 'bold)
573 (set-extent-property extent 'highlight t)
574 (set-extent-property extent 'headers t)
575 (set-extent-property extent 'keymap highlight-headers-url-keymap)))
576 ))))
577
578
579 (provide 'highlight-headers)