emh-face.el

   1 ;;; emh-face.el --- header highlighting in emh.
   2
   3 ;; Copyright (C) 1997 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1997/3/4
   7 ;; Version: $Id: emh-face.el,v 0.2 1997-03-14 05:30:33 morioka Exp $
   8 ;; Keywords: header, highlighting
   9
  10 ;; This file is part of emh.
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'emu)
  30
  31 (defsubst emh-set-face-foreground (face color)
  32   (condition-case err
  33       (set-face-foreground face color)
  34     (error (message "Color `%s' is not found." color))
  35     ))
  36
  37 (or (find-face 'from-field-body)
  38     (progn
  39       (make-face 'from-field-body)
  40       (emh-set-face-foreground 'from-field-body "dark slate blue")
  41       (make-face-bold 'from-field-body nil 'no-error)
  42       ))
  43
  44 (or (find-face 'subject-field-body)
  45     (progn
  46       (make-face 'subject-field-body)
  47       (emh-set-face-foreground 'subject-field-body "violet red")
  48       (make-face-bold 'subject-field-body nil 'no-error)
  49       ))
  50
  51 (or (find-face 'to-field-body)
  52     (progn
  53       (make-face 'to-field-body)
  54       (emh-set-face-foreground 'to-field-body "red")
  55       (make-face-bold 'to-field-body nil 'no-error)
  56       ))
  57
  58 (or (find-face 'cc-field-body)
  59     (progn
  60       (make-face 'cc-field-body)
  61       (emh-set-face-foreground 'cc-field-body "salmon")
  62       (make-face-bold 'cc-field-body nil 'no-error)
  63       ))
  64
  65 (or (find-face 'reply-to-field-body)
  66     (progn
  67       (make-face 'reply-to-field-body)
  68       (emh-set-face-foreground 'reply-to-field-body "salmon")
  69       (make-face-bold 'reply-to-field-body nil 'no-error)
  70       ))
  71
  72 (or (find-face '-to-field-body)
  73     (progn
  74       (make-face '-to-field-body)
  75       (emh-set-face-foreground '-to-field-body "red")
  76       ))
  77
  78 (or (find-face 'date-field-body)
  79     (progn
  80       (make-face 'date-field-body)
  81       (emh-set-face-foreground 'date-field-body "blue violet")
  82       (make-face-bold 'date-field-body nil 'no-error)
  83       ))
  84
  85 (or (find-face 'message-id-field-body)
  86     (progn
  87       (make-face 'message-id-field-body)
  88       (emh-set-face-foreground 'message-id-field-body "royal blue")
  89       (make-face-bold 'message-id-field-body nil 'no-error)
  90       ))
  91
  92 (or (find-face 'field-body)
  93     (progn
  94       (make-face 'field-body)
  95       (emh-set-face-foreground 'field-body "dark green")
  96       (make-face-italic 'field-body nil 'no-error)
  97       ))
  98
  99 (or (find-face 'field-name)
 100     (progn
 101       (make-face 'field-name)
 102       (emh-set-face-foreground 'field-name "dark green")
 103       (make-face-bold 'field-name nil 'no-error)
 104       ))
 105
 106 (defvar emh-header-face
 107   '(("^From:"           field-name      from-field-body)
 108     ("^Subject:"        field-name      subject-field-body)
 109     ("^To:"             field-name      to-field-body)
 110     ("^cc:"             field-name      cc-field-body)
 111     ("^Reply-To:"       field-name      reply-to-field-body)
 112     ("^.+-To:"          field-name      -to-field-body)
 113     ("^Date:"           field-name      date-field-body)
 114     ("^Message-Id:"     field-name      message-id-field-body)
 115     (t                  field-name      field-body)
 116     ))
 117
 118 (defun emh-highlight-header ()
 119   (goto-char (point-min))
 120   (while (looking-at "^[^:]+:")
 121     (let* ((beg (match-beginning 0))
 122            (med (match-end 0))
 123            (end (std11-field-end))
 124            (field-name (buffer-substring beg med))
 125            (rule (cdr (or (assoc-if (function
 126                                      (lambda (key)
 127                                        (and (stringp key)
 128                                             (string-match key field-name)
 129                                             )))
 130                                     emh-header-face)
 131                           (assq t emh-header-face)
 132                           )))
 133            )
 134       (overlay-put (make-overlay beg med) 'face (car rule))
 135       (overlay-put (make-overlay med end) 'face (second rule))
 136       )
 137     (forward-char)
 138     ))
 139
 140
 141 ;;; @ end
 142 ;;;
 143
 144 (provide 'emh-face)
 145
 146 ;;; emh-face.el ends here