cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-highlight.el

   1 ;;; mew-highlight.el --- Highlight for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Oct 18, 1997
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-highlight-version "mew-highlight.el version 0.04")
  10
  11 (require 'mew)
  12
  13 ;;
  14 ;; functions
  15 ;;
  16
  17 (defun mew-summary-highlight-setup ()
  18   "A function to setup mouse line for Summary and Virtual mode."
  19   (if (and mew-xemacs-p mew-use-highlight-mouse-line)
  20       (setq mode-motion-hook mew-highlight-mouse-line-function)))
  21
  22 (defalias 'mew-virtual-highlight-setup 'mew-summary-highlight-setup)
  23
  24 (defun mew-highlight-cursor-line ()
  25   "A function to highlight the cursor line in Summary and Virtual mode."
  26   (if mew-use-highlight-cursor-line
  27       (mew-elet
  28        (if (mew-overlay-p mew-overlay-cursor-line)
  29            (mew-overlay-move mew-overlay-cursor-line
  30                              (save-excursion (beginning-of-line) (point))
  31                              (save-excursion (end-of-line) (point)))
  32          (setq mew-overlay-cursor-line
  33                (mew-overlay-make
  34                 (save-excursion (beginning-of-line) (point))
  35                 (save-excursion (end-of-line) (point))))
  36          (mew-overlay-put mew-overlay-cursor-line 'face
  37                           mew-highlight-cursor-line-face))))
  38   (if mew-use-cursor-mark
  39       (progn
  40         (if (mew-local-variable-p 'overlay-arrow-position)
  41             ()
  42           (make-local-variable 'overlay-arrow-position)
  43           (setq overlay-arrow-position (make-marker)))
  44         (if (mew-local-variable-p 'overlay-arrow-string)
  45             ()
  46           (make-local-variable 'overlay-arrow-string)
  47           (setq overlay-arrow-string mew-cursor-mark))
  48         (set-marker overlay-arrow-position
  49                     (save-excursion (beginning-of-line) (point))))))
  50
  51 (defun mew-highlight-url ()
  52   "A function to highlight URL in Message mode."
  53   (if mew-use-highlight-url
  54       (save-excursion
  55         (mew-elet
  56          (let ((url-regex mew-use-highlight-url-regex)
  57                bound overlay)
  58            (goto-char (point-min))
  59            (setq bound
  60                  (if mew-highlight-url-max-size
  61                      (save-excursion
  62                        (goto-char (+ mew-highlight-url-max-size (point)))
  63                        (end-of-line)
  64                        (point))
  65                    nil))
  66            (while (re-search-forward url-regex bound t)
  67              (setq overlay (mew-overlay-make (match-beginning 0)
  68                                              (match-end 0)))
  69              (mew-overlay-put overlay 'face mew-highlight-url-face)
  70              (mew-overlay-put overlay
  71                               'mouse-face mew-highlight-url-mouse-face)))))))
  72
  73
  74 (defmacro mew-highlight-this-folder-p ()
  75   '(and (or window-system mew-xemacs-p) mew-use-highlight-mark
  76         (or (eq mew-highlight-mark-folder-list t)
  77             (mew-folder-member (buffer-name)
  78                                mew-highlight-mark-folder-list))))
  79
  80 (defun mew-highlight-mark-region (beg end)
  81   (interactive "r")
  82   (if (mew-highlight-this-folder-p)
  83       (save-excursion
  84         (mew-elet
  85          (let ((regex (concat mew-summary-message-regex "\\([^ ]\\)"))
  86                face)
  87            (goto-char beg)
  88            (while (re-search-forward regex end t)
  89              (setq face (cdr (assoc (string-to-char (mew-match 2))
  90                                     mew-highlight-mark-keywords)))
  91              (if face
  92                  (put-text-property
  93                   (save-excursion (beginning-of-line) (point))
  94                   (save-excursion (end-of-line) (point))
  95                   'face face))))))))
  96
  97 (defun mew-highlight-mark-line (mark)
  98   (if (mew-highlight-this-folder-p)
  99       (mew-elet
 100        (let ((face (cdr (assoc mark mew-highlight-mark-keywords))))
 101          (if face
 102              (put-text-property
 103               (save-excursion (beginning-of-line) (point))
 104               (save-excursion (end-of-line) (point))
 105               'face face))))))
 106
 107 (defun mew-highlight-unmark-line ()
 108   (if (mew-highlight-this-folder-p)
 109       (remove-text-properties
 110        (save-excursion (beginning-of-line) (point))
 111        (save-excursion (end-of-line) (point))
 112        '(face nil))))
 113
 114 (defun mew-unhighlight-region (BEG END)
 115   (mew-overlay-delete-region BEG END))
 116
 117 (defun mew-unhighlight-header ()
 118   (save-restriction
 119     (widen)
 120     (mew-unhighlight-region (point-min) (mew-header-end))))
 121
 122 (defun mew-unhighlight-body ()
 123   (save-restriction
 124     (widen)
 125     (mew-unhighlight-region
 126      (+ (mew-header-end) (length mew-header-separator) 1)
 127      (or (mew-attach-begin) (point-max)))))
 128
 129 (defun mew-highlight-header-region (BEG END)
 130   "A function to highlight header in Message and Draft mode."
 131   (if (and (or window-system mew-xemacs-p) mew-use-highlight-header)
 132       (mew-elet
 133        (let ((defkey (intern-soft "mew-highlight-header-face-key"))
 134              (defval (intern-soft "mew-highlight-header-face-marginal"))
 135              key beg med n-spec overlay key-face val-face)
 136          (save-excursion
 137            (mew-unhighlight-region BEG END)
 138            (save-restriction
 139              (narrow-to-region BEG END)
 140              (goto-char (point-min))
 141              (while (not (eobp))
 142                (if (not (looking-at mew-keyval))
 143                    (forward-line)
 144                  (setq key (mew-match 1))
 145                  (setq beg (match-beginning 0))
 146                  (setq med (match-end 0))
 147                  (forward-line)
 148                  (mew-header-goto-next)
 149                  (setq n-spec (mew-assoc-match3 key mew-field-spec 0))
 150                  (setq key-face (or (nth 3 n-spec) defkey))
 151                  (setq val-face (or (nth 4 n-spec) defval))
 152                  (setq overlay (mew-overlay-make beg med))
 153                  (mew-overlay-put overlay 'face key-face)
 154                  (setq overlay (mew-overlay-make med (point)))
 155                  (mew-overlay-put overlay 'face val-face)))))))))
 156
 157 (defun mew-highlight-header ()
 158   (save-restriction
 159     (widen)
 160     (mew-highlight-header-region (point-min) (mew-header-end))))
 161
 162 (defun mew-highlight-body ()
 163   "A function to highlight body in Message mode."
 164   (if (and (or window-system mew-xemacs-p) mew-use-highlight-body)
 165       (save-excursion
 166         (save-restriction
 167           (mew-elet
 168            (let ((keywords mew-highlight-body-keywords)
 169                  (line 1)
 170                  beg1 end1 overlay assoc key)
 171              (widen)
 172              (if (mew-header-p)
 173                  (progn
 174                    (mew-unhighlight-body)
 175                    (goto-char (mew-header-end))
 176                    (narrow-to-region (point)
 177                                      (or (mew-attach-begin) (point-max)))))
 178              (while (and (not (eobp)) (< line mew-highlight-body-max-line))
 179                (if (looking-at mew-highlight-body-keywords-regex)
 180                    (progn
 181                      (setq beg1 (match-beginning 0))
 182                      (setq end1 (match-end 0))
 183                      (setq key (mew-match 0))
 184                      (if (setq assoc (mew-assoc-match2 key keywords 0))
 185                          (progn
 186                            (setq overlay (mew-overlay-make beg1 end1))
 187                            (mew-overlay-put overlay 'face (nth 1 assoc))))))
 188                (forward-line)
 189                (setq line (1+ line)))))))))
 190
 191 ;;
 192 ;; X-Face:
 193 ;;
 194
 195 ;; uncompface: ftp://ftp.cs.indiana.edu/pub/faces/xfaces/xfaces-<ver>.tar.Z
 196 ;; icontopbm: ftp://ftp.x.org/R5contrib/netpbm-<ver>.tar.gz
 197
 198 (defun mew-highlight-x-face (beg end)
 199   "A function to display X-Face."
 200   (if (and mew-use-highlight-x-face mew-use-highlight-x-face-function)
 201       (funcall mew-use-highlight-x-face-function beg end)))
 202
 203 (cond
 204  (mew-xemacs-p
 205   ;;(autoload 'highlight-headers-x-face-to-pixmap "highlight-headers")
 206   (if (mew-which-el "highlight-headers" load-path)
 207       (require 'highlight-headers)) ;; due to the timing problem.
 208   ;; now this is in the "mail-lib" package.
 209   (defvar mew-use-highlight-x-face-function
 210     (function (lambda (beg end)
 211                 (interactive)
 212                 (if (and (or window-system mew-xemacs-p)
 213                          (mew-which mew-prog-uncompface exec-path)
 214                          mew-use-highlight-x-face)
 215                     (save-excursion
 216                       (goto-char beg)
 217                       (mew-elet
 218                        (let (overlay xface)
 219                          (while (re-search-forward
 220                                  "^X-Face: *\\(.*\\(\n[ \t].*\\)*\\)\n" end t)
 221                            (setq overlay (mew-overlay-make (match-beginning 0)
 222                                                            (match-end 0)))
 223                            (mew-overlay-put overlay 'invisible t)
 224                            (setq xface (highlight-headers-x-face-to-pixmap
 225                                         (match-beginning 1)
 226                                         (match-end 1)))
 227                            (save-excursion
 228                              (goto-char beg)
 229                              (if (re-search-forward
 230                                   (concat "^\\(" mew-from: "\\).*") end t)
 231                                  (progn
 232                                    (setq overlay (mew-overlay-make
 233                                                   (match-end 1) (match-end 1)))
 234                                    (set-extent-begin-glyph overlay xface))))
 235                            )))))))))
 236  (t
 237   (defvar mew-use-highlight-x-face-function nil
 238     "*On Text Emacs, this function is called if mew-use-highlight-x-face
 239 is *non-nil*. This is a temporary solution.")
 240   (if (and mew-use-highlight-x-face
 241            (mew-which mew-prog-uncompface exec-path)
 242            (mew-which-el "bitmap" load-path)
 243            (mew-which-el "mew-xface-mule" load-path))
 244       (require 'mew-xface-mule))))
 245
 246 ;;
 247 ;; Setup
 248 ;;
 249
 250 (defun mew-highlight-face-setup (flist)
 251   "A function to create faces according to FLIST.
 252 FLIST is a list of face name symbol and its name convention is
 253 'mew-highlight-<word1>-face-<word2>'. A base face is copied from
 254 'mew-highlight-<word1>-style-<word2>' then a color is set from
 255 'mew-highlight-<word1>-color-<word2>'."
 256   (if (or window-system mew-xemacs-p)
 257       (let (fname str style color)
 258         (while flist
 259           (setq fname (car flist))
 260           (setq flist (cdr flist))
 261           (set fname fname)
 262           (setq str (symbol-name fname))
 263           (string-match "^\\(mew-highlight-.*-\\)face\\(-.*\\)$" str)
 264           (setq style (intern-soft
 265                        (concat (mew-match 1 str) "style" (mew-match 2 str))))
 266           (setq color (intern-soft
 267                        (concat (mew-match 1 str) "color" (mew-match 2 str))))
 268           (copy-face (symbol-value style) fname)
 269           (set-face-foreground fname (symbol-value color))))))
 270
 271 (defun mew-highlight-make-keywords-regex ()
 272   (setq mew-highlight-body-keywords-regex
 273         (mapconcat (function car) mew-highlight-body-keywords "\\|")))
 274
 275 (provide 'mew-highlight)
 276
 277 ;;; Copyright Notice:
 278
 279 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 280 ;; All rights reserved.
 281
 282 ;; Redistribution and use in source and binary forms, with or without
 283 ;; modification, are permitted provided that the following conditions
 284 ;; are met:
 285 ;;
 286 ;; 1. Redistributions of source code must retain the above copyright
 287 ;;    notice, this list of conditions and the following disclaimer.
 288 ;; 2. Redistributions in binary form must reproduce the above copyright
 289 ;;    notice, this list of conditions and the following disclaimer in the
 290 ;;    documentation and/or other materials provided with the distribution.
 291 ;; 3. Neither the name of the team nor the names of its contributors
 292 ;;    may be used to endorse or promote products derived from this software
 293 ;;    without specific prior written permission.
 294 ;;
 295 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 296 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 297 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 298 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 299 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 300 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 301 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 302 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 303 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 304 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 305 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 306
 307 ;;; mew-highlight.el ends here