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.0 1997-03-04 20:17:52 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 (or (find-face 'from-field-body)
  30     (progn
  31       (make-face 'from-field-body)
  32       (and (member "blue" (x-defined-colors))
  33            (set-face-foreground 'from-field-body "blue")
  34            )
  35       ))
  36 (or (find-face 'from-field-name)
  37     (progn
  38       (copy-face 'from-field-body 'from-field-name)
  39       (make-face-bold 'from-field-name nil 'no-error)
  40       ))
  41
  42 (or (find-face 'subject-field-body)
  43     (progn
  44       (make-face 'subject-field-body)
  45       (and (member "violet red" (x-defined-colors))
  46            (set-face-foreground 'subject-field-body "violet red")
  47            )
  48       ))
  49 (or (find-face 'subject-field-name)
  50     (progn
  51       (copy-face 'subject-field-body 'subject-field-name)
  52       (make-face-bold 'subject-field-name nil 'no-error)
  53       ))
  54
  55 (or (find-face 'to-field-body)
  56     (progn
  57       (make-face 'to-field-body)
  58       (and (member "red" (x-defined-colors))
  59            (set-face-foreground 'to-field-body "red")
  60            )
  61       ))
  62 (or (find-face 'to-field-name)
  63     (progn
  64       (copy-face 'to-field-body 'to-field-name)
  65       (make-face-bold 'to-field-name nil 'no-error)
  66       ))
  67
  68 (or (find-face 'cc-field-body)
  69     (progn
  70       (make-face 'cc-field-body)
  71       (and (member "pink" (x-defined-colors))
  72            (set-face-foreground 'cc-field-body "pink")
  73            )
  74       ))
  75 (or (find-face 'cc-field-name)
  76     (progn
  77       (copy-face 'cc-field-body 'cc-field-name)
  78       (make-face-bold 'cc-field-name nil 'no-error)
  79       ))
  80
  81 (or (find-face '-to-field-body)
  82     (progn
  83       (make-face '-to-field-body)
  84       (and (member "salmon" (x-defined-colors))
  85            (set-face-foreground '-to-field-body "salmon")
  86            )
  87       ))
  88 (or (find-face '-to-field-name)
  89     (progn
  90       (copy-face '-to-field-body '-to-field-name)
  91       (make-face-bold '-to-field-name nil 'no-error)
  92       ))
  93
  94 (or (find-face 'date-field-body)
  95     (progn
  96       (make-face 'date-field-body)
  97       (and (member "blue violet" (x-defined-colors))
  98            (set-face-foreground 'date-field-body "blue violet")
  99            )
 100       ))
 101 (or (find-face 'date-field-name)
 102     (progn
 103       (copy-face 'date-field-body 'date-field-name)
 104       (make-face-bold 'date-field-name nil 'no-error)
 105       ))
 106
 107 (or (find-face 'message-id-field-body)
 108     (progn
 109       (make-face 'message-id-field-body)
 110       (and (member "royal blue" (x-defined-colors))
 111            (set-face-foreground 'message-id-field-body "royal blue")
 112            )
 113       ))
 114 (or (find-face 'message-id-field-name)
 115     (progn
 116       (copy-face 'message-id-field-body 'message-id-field-name)
 117       (make-face-bold 'message-id-field-name nil 'no-error)
 118       ))
 119
 120 (or (find-face 'field-body)
 121     (progn
 122       (make-face 'field-body)
 123       (and (member "dark green" (x-defined-colors))
 124            (set-face-foreground 'field-body "dark green")
 125            )
 126       (make-face-italic 'field-body nil 'no-error)
 127       ))
 128 (or (find-face 'field-name)
 129     (progn
 130       (make-face 'field-name)
 131       (and (member "dark green" (x-defined-colors))
 132            (set-face-foreground 'field-name "dark green")
 133            )
 134       (make-face-bold 'field-name nil 'no-error)
 135       ))
 136
 137 (defvar emh-header-face
 138   '(("^From:"           from-field-name         from-field-body)
 139     ("^Subject:"        subject-field-name      subject-field-body)
 140     ("^To:"             to-field-name           to-field-body)
 141     ("^cc:"             cc-field-name           cc-field-body)
 142     ("^.+-To:"          -to-field-name          -to-field-body)
 143     ("^Date:"           date-field-name         date-field-body)
 144     ("^Message-Id:"     message-id-field-name   message-id-field-body)
 145     (t                  field-name              field-body)
 146     ))
 147
 148 (defun emh-highlight-header ()
 149   (goto-char (point-min))
 150   (while (looking-at "^[^:]+:")
 151     (let* ((beg (match-beginning 0))
 152            (med (match-end 0))
 153            (end (std11-field-end))
 154            (field-name (buffer-substring beg med))
 155            (rule (cdr (or (assoc-if (function
 156                                      (lambda (key)
 157                                        (and (stringp key)
 158                                             (string-match key field-name)
 159                                             )))
 160                                     emh-header-face)
 161                           (assq t emh-header-face)
 162                           )))
 163            )
 164       (overlay-put (make-overlay beg med) 'face (car rule))
 165       (overlay-put (make-overlay med end) 'face (second rule))
 166       )
 167     (forward-char)
 168     ))
 169
 170
 171 ;;; @ end
 172 ;;;
 173
 174 (provide 'emh-face)
 175
 176 ;;; emh-face.el ends here