X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=emh-face.el;h=2014d2316a2434bc6bc1597e63f47a8e2920996f;hb=f144e8c07adc195632bbb6c3bd1efcebc31ea0f8;hp=3197e754d862d6ac81d08b71773ba6a27c8519db;hpb=a6e7b8f8b189fabaa3e48af92607725492e8534d;p=elisp%2Femh.git diff --git a/emh-face.el b/emh-face.el index 3197e75..2014d23 100644 --- a/emh-face.el +++ b/emh-face.el @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1997/3/4 -;; Version: $Id: emh-face.el,v 0.0 1997-03-04 20:17:52 morioka Exp $ +;; Version: $Id: emh-face.el,v 0.5 1997-09-25 15:11:34 morioka Exp $ ;; Keywords: header, highlighting ;; This file is part of emh. @@ -26,123 +26,101 @@ ;;; Code: +(require 'emu) + +(defsubst emh-set-face-foreground (face color) + (condition-case err + (set-face-foreground face color) + (error (message "Color `%s' is not found." color)) + )) + +(defsubst emh-make-face-bold (face) + (set-face-font face (face-font 'bold)) + ) + +(defsubst emh-make-face-italic (face) + (set-face-font face (face-font 'italic)) + ) + (or (find-face 'from-field-body) (progn (make-face 'from-field-body) - (and (member "blue" (x-defined-colors)) - (set-face-foreground 'from-field-body "blue") - ) - )) -(or (find-face 'from-field-name) - (progn - (copy-face 'from-field-body 'from-field-name) - (make-face-bold 'from-field-name nil 'no-error) + (emh-set-face-foreground 'from-field-body "dark slate blue") + (emh-make-face-bold 'from-field-body) )) (or (find-face 'subject-field-body) (progn (make-face 'subject-field-body) - (and (member "violet red" (x-defined-colors)) - (set-face-foreground 'subject-field-body "violet red") - ) - )) -(or (find-face 'subject-field-name) - (progn - (copy-face 'subject-field-body 'subject-field-name) - (make-face-bold 'subject-field-name nil 'no-error) + (emh-set-face-foreground 'subject-field-body "violet red") + (emh-make-face-bold 'subject-field-body) )) (or (find-face 'to-field-body) (progn (make-face 'to-field-body) - (and (member "red" (x-defined-colors)) - (set-face-foreground 'to-field-body "red") - ) - )) -(or (find-face 'to-field-name) - (progn - (copy-face 'to-field-body 'to-field-name) - (make-face-bold 'to-field-name nil 'no-error) + (emh-set-face-foreground 'to-field-body "red") + (emh-make-face-bold 'to-field-body) )) (or (find-face 'cc-field-body) (progn (make-face 'cc-field-body) - (and (member "pink" (x-defined-colors)) - (set-face-foreground 'cc-field-body "pink") - ) + (emh-set-face-foreground 'cc-field-body "salmon") + (emh-make-face-bold 'cc-field-body) )) -(or (find-face 'cc-field-name) + +(or (find-face 'reply-to-field-body) (progn - (copy-face 'cc-field-body 'cc-field-name) - (make-face-bold 'cc-field-name nil 'no-error) + (make-face 'reply-to-field-body) + (emh-set-face-foreground 'reply-to-field-body "salmon") + (emh-make-face-bold 'reply-to-field-body) )) (or (find-face '-to-field-body) (progn (make-face '-to-field-body) - (and (member "salmon" (x-defined-colors)) - (set-face-foreground '-to-field-body "salmon") - ) - )) -(or (find-face '-to-field-name) - (progn - (copy-face '-to-field-body '-to-field-name) - (make-face-bold '-to-field-name nil 'no-error) + (emh-set-face-foreground '-to-field-body "red") )) (or (find-face 'date-field-body) (progn (make-face 'date-field-body) - (and (member "blue violet" (x-defined-colors)) - (set-face-foreground 'date-field-body "blue violet") - ) - )) -(or (find-face 'date-field-name) - (progn - (copy-face 'date-field-body 'date-field-name) - (make-face-bold 'date-field-name nil 'no-error) + (emh-set-face-foreground 'date-field-body "blue violet") + (emh-make-face-bold 'date-field-body) )) (or (find-face 'message-id-field-body) (progn (make-face 'message-id-field-body) - (and (member "royal blue" (x-defined-colors)) - (set-face-foreground 'message-id-field-body "royal blue") - ) - )) -(or (find-face 'message-id-field-name) - (progn - (copy-face 'message-id-field-body 'message-id-field-name) - (make-face-bold 'message-id-field-name nil 'no-error) + (emh-set-face-foreground 'message-id-field-body "royal blue") + (emh-make-face-bold 'message-id-field-body) )) (or (find-face 'field-body) (progn (make-face 'field-body) - (and (member "dark green" (x-defined-colors)) - (set-face-foreground 'field-body "dark green") - ) - (make-face-italic 'field-body nil 'no-error) + (emh-set-face-foreground 'field-body "dark green") + (emh-make-face-italic 'field-body) )) + (or (find-face 'field-name) (progn (make-face 'field-name) - (and (member "dark green" (x-defined-colors)) - (set-face-foreground 'field-name "dark green") - ) - (make-face-bold 'field-name nil 'no-error) + (emh-set-face-foreground 'field-name "dark green") + (emh-make-face-bold 'field-name) )) (defvar emh-header-face - '(("^From:" from-field-name from-field-body) - ("^Subject:" subject-field-name subject-field-body) - ("^To:" to-field-name to-field-body) - ("^cc:" cc-field-name cc-field-body) - ("^.+-To:" -to-field-name -to-field-body) - ("^Date:" date-field-name date-field-body) - ("^Message-Id:" message-id-field-name message-id-field-body) - (t field-name field-body) + '(("^From:" field-name from-field-body) + ("^Subject:" field-name subject-field-body) + ("^To:" field-name to-field-body) + ("^cc:" field-name cc-field-body) + ("^Reply-To:" field-name reply-to-field-body) + ("^.+-To:" field-name -to-field-body) + ("^Date:" field-name date-field-body) + ("^Message-Id:" field-name message-id-field-body) + (t field-name field-body) )) (defun emh-highlight-header () @@ -152,17 +130,22 @@ (med (match-end 0)) (end (std11-field-end)) (field-name (buffer-substring beg med)) - (rule (cdr (or (assoc-if (function - (lambda (key) - (and (stringp key) - (string-match key field-name) - ))) - emh-header-face) - (assq t emh-header-face) - ))) + (rule (catch 'found + (let ((rest emh-header-face)) + (while rest + (let* ((rule (car rest)) + (key (car rule))) + (if (and (stringp key) + (string-match key field-name)) + (throw 'found (cdr rule)) + )) + (setq rest (cdr rest)) + ) + (cdr (assq t emh-header-face)) + ))) ) (overlay-put (make-overlay beg med) 'face (car rule)) - (overlay-put (make-overlay med end) 'face (second rule)) + (overlay-put (make-overlay med end) 'face (cadr rule)) ) (forward-char) ))