home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / utils / highlight-headers.el < prev    next >
Encoding:
Text File  |  1993-02-17  |  6.8 KB  |  201 lines
  1. ;;; Highlighting message headers.
  2. ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; This code is shared by RMAIL, VM, and GNUS.
  21. ;;
  22. ;; Faces:
  23. ;;
  24. ;; message-headers            the part before the colon
  25. ;; message-header-contents        the part after the colon
  26. ;; message-highlighted-header-contents    contents of "special" headers
  27. ;; message-cited-text            quoted text from other messages
  28. ;;
  29. ;; Variables:
  30. ;;
  31. ;; highlight-headers-regexp            what makes a "special" header
  32. ;; highlight-headers-citation-regexp        matches lines of quoted text
  33. ;; highlight-headers-citation-header-regexp    matches headers for quoted text
  34.  
  35.  
  36. (make-face 'message-headers)
  37. (make-face 'message-header-contents)
  38. (make-face 'message-highlighted-header-contents)
  39. (make-face 'message-cited-text)
  40. ;;(make-face 'message-addresses)
  41.  
  42. (or (face-differs-from-default-p 'message-headers)
  43.     (copy-face 'bold 'message-headers))
  44.  
  45. (or (face-differs-from-default-p 'message-header-contents)
  46.     (copy-face 'italic 'message-header-contents))
  47.  
  48. (or (face-differs-from-default-p 'message-highlighted-header-contents)
  49.     (progn
  50.       (copy-face 'message-header-contents
  51.          'message-highlighted-header-contents)
  52.       (set-face-underline-p 'message-highlighted-header-contents t)))
  53.  
  54. (or (face-differs-from-default-p 'message-cited-text)
  55.     (copy-face 'italic 'message-cited-text))
  56.  
  57. ;;(or (face-differs-from-default-p 'message-addresses)
  58. ;;    (progn
  59. ;;      (copy-face 'bold-italic 'message-addresses)
  60. ;;      (set-face-underline-p 'message-addresses
  61. ;;       (face-underline-p 'message-highlighted-header-contents))))
  62.  
  63.  
  64. (defvar highlight-headers-regexp "Subject[ \t]*:"
  65.   "*The headers whose contents should be emphasized more.
  66. The contents of these headers will be displayed in the face 
  67. `message-highlighted-header-contents' instead of `message-header-contents'.")
  68.  
  69. (defvar highlight-headers-citation-regexp "^[ \t]*[A-Z]*[]}<>|][ \t]*"
  70.   "*The pattern to match cited text.
  71. Text in the body of a message which matches this will be displayed in
  72. the face `message-cited-text'.")
  73.  
  74. (defvar highlight-headers-citation-header-regexp
  75.   (concat "^In article\\|^In message\\|"
  76.       "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]*[A-Z]*[]}<>|]")
  77.   "*The pattern to match the prolog of a cited block.
  78. Text in the body of a message which matches this will be displayed in
  79. the `message-headers' face.")
  80.  
  81. (defun highlight-headers (start end hack-sig)
  82.   "Highlight message headers between start and end.
  83. Faces used:
  84.   message-headers            the part before the colon
  85.   message-header-contents        the part after the colon
  86.   message-highlighted-header-contents    contents of \"special\" headers
  87.   message-cited-text            quoted text from other messages
  88.  
  89. Variables used:
  90.  
  91.   highlight-headers-regexp            what makes a \"special\" header
  92.   highlight-headers-citation-regexp        matches lines of quoted text
  93.   highlight-headers-citation-header-regexp    matches headers for quoted text
  94.  
  95. If HACK-SIG is true,then we search backward from END for something that
  96. looks like the beginning of a signature block, and don't consider that a
  97. part of the message (this is because signatures are often incorrectly
  98. interpreted as cited text.)"
  99.   (let* ((current 'message-header-contents)
  100.      e p)
  101.     ;; delete previous highlighting
  102.     (map-extents (function (lambda (extent ignore)
  103.                  (if (eq (extent-data extent) 'headers)
  104.                  (delete-extent extent))))
  105.          (current-buffer) start end)
  106.     (save-excursion
  107.       (save-restriction
  108.     (widen)
  109.     ;; take off signature
  110.     (if hack-sig
  111.         (save-excursion
  112.           (goto-char end)
  113.           (if (re-search-backward "\n--+ *\n" start t)
  114.           (setq end (point)))))
  115.  
  116.     (narrow-to-region start end)
  117.  
  118.     (goto-char start)
  119.     (while (and (not (eobp))
  120.             (not (= (following-char) ?\n)))
  121.       (cond
  122.        ((looking-at "^[^ \t\n]+[ \t]*:")
  123.         (setq e (make-extent (match-beginning 0) (match-end 0)))
  124.         (set-extent-face e 'message-headers)
  125.         (set-extent-data e 'headers)
  126.         (setq p (match-end 0))
  127.         (cond
  128.          ((and highlight-headers-regexp
  129.            (looking-at highlight-headers-regexp))
  130.           (setq current 'message-highlighted-header-contents)
  131.           (end-of-line)
  132.           (setq e (make-extent p (point)))
  133.           (set-extent-face e current)
  134.           (set-extent-data e 'headers)
  135.           )
  136. ;; I don't think this is worth the effort
  137. ;;         ((looking-at "\\(From\\|Resent-From\\)[ \t]*:")
  138. ;;          (setq current 'message-highlighted-header-contents)
  139. ;;          (goto-char (match-end 0))
  140. ;;          (or (looking-at ".*(\\(.*\\))")
  141. ;;          (looking-at "\\(.*\\)<")
  142. ;;          (looking-at "\\(.*\\)[@%]")
  143. ;;          (looking-at "\\(.*\\)"))
  144. ;;          (end-of-line)
  145. ;;          (setq e (make-extent p (match-beginning 1)))
  146. ;;          (set-extent-face e current)
  147. ;;          (set-extent-data e 'headers)
  148. ;;          (setq e (make-extent (match-beginning 1) (match-end 1)))
  149. ;;          (set-extent-face e 'message-addresses)
  150. ;;          (set-extent-data e 'headers)
  151. ;;          (setq e (make-extent (match-end 1) (point)))
  152. ;;          (set-extent-face e current)
  153. ;;          (set-extent-data e 'headers)
  154. ;;          )
  155.          (t
  156.           (setq current 'message-header-contents)
  157.           (end-of-line)
  158.           (setq e (make-extent p (point)))
  159.           (set-extent-face e current)
  160.           (set-extent-data e 'headers)
  161.           )))
  162.        (t
  163.         (setq p (point))
  164.         (end-of-line)
  165.         (setq e (make-extent p (point)))
  166.         (set-extent-face e current)
  167.         (set-extent-data e 'headers)
  168.         ))
  169.       (forward-line 1))
  170.  
  171.     (while (not (eobp))
  172.       (cond ((null highlight-headers-citation-regexp)
  173.          nil)
  174.         ((looking-at highlight-headers-citation-regexp)
  175.          (goto-char (match-end 0))
  176.          (or (save-excursion
  177.                (beginning-of-line)
  178.                (let ((case-fold-search nil)) ; aaaaah, unix...
  179.              (looking-at "^>From ")))
  180.              (setq current 'message-cited-text)))
  181. ;;        ((or (looking-at "^In article\\|^In message")
  182. ;;             (looking-at
  183. ;;          "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]+[A-Z]*[]}<>|]"))
  184. ;;         (setq current 'message-headers))
  185.         ((null highlight-headers-citation-header-regexp)
  186.          nil)
  187.         ((looking-at highlight-headers-citation-header-regexp)
  188.          (setq current 'message-headers))
  189.         (t (setq current nil)))
  190.       (cond (current
  191.          (setq p (point))
  192.          (end-of-line)
  193.          (setq e (make-extent p (point)))
  194.          (set-extent-face e current)
  195.          (set-extent-data e 'headers)
  196.          ))
  197.       (forward-line 1))))
  198.     ))
  199.  
  200. (provide 'highlight-headers)
  201.