wl/wl-highlight.el

   1 ;;; wl-highlight.el -- Hilight modules for Wanderlust.
   2
   3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (if (and (featurep 'xemacs)
  33          (featurep 'dragdrop))
  34     (require 'wl-dnd))
  35 (require 'wl-vars)
  36 (require 'product)
  37 (product-provide (provide 'wl-highlight) (require 'wl-version))
  38
  39 (eval-when-compile
  40   (cond (wl-on-xemacs
  41          (require 'wl-xmas))
  42         (wl-on-emacs21
  43          (require 'wl-e21))
  44         (wl-on-nemacs
  45          (require 'wl-nemacs))
  46         (t
  47          (require 'wl-mule)))
  48   (defun-maybe extent-begin-glyph (a))
  49   (defun-maybe delete-extent (a))
  50   (defun-maybe make-extent (a b))
  51   (defun-maybe set-extent-begin-glyph (a b))
  52   (defun-maybe set-extent-end-glyph (a b))
  53   (defun-maybe extent-at (a b c d e))
  54   (defun-maybe wl-dnd-set-drop-target (a b))
  55   (defun-maybe wl-dnd-set-drag-starter (a b)))
  56
  57 (put 'wl-defface 'lisp-indent-function 'defun)
  58
  59 (defgroup wl-faces nil
  60   "Wanderlust, Faces."
  61   :prefix "wl-highlight-"
  62   :group 'wl-highlight
  63   :group 'wl)
  64
  65 (defgroup wl-summary-faces nil
  66   "Wanderlust, Faces of summary buffer."
  67   :prefix "wl-highlight-"
  68   :group 'wl-highlight
  69   :group 'wl-summary)
  70
  71 (defgroup wl-folder-faces nil
  72   "Wanderlust, Faces of folder buffer."
  73   :prefix "wl-highlight-"
  74   :group 'wl-highlight
  75   :group 'wl-folder)
  76
  77 (defgroup wl-message-faces nil
  78   "Wanderlust, Faces of message buffer."
  79   :prefix "wl-highlight-"
  80   :group 'wl-highlight)
  81
  82 ;; for message header and signature
  83
  84 (wl-defface wl-highlight-message-headers
  85   '(
  86     (((type tty)
  87       (background dark))
  88      (:foreground "cyan"))
  89     (((class color)
  90       (background dark))
  91      (:foreground "gray" :bold t))
  92     (((class color)
  93       (background light))
  94      (:foreground "gray50" :bold t)))
  95   "Face used for displaying header names."
  96   :group 'wl-message-faces
  97   :group 'wl-faces)
  98
  99 (wl-defface wl-highlight-message-header-contents
 100   '(
 101     (((type tty)
 102       (background dark))
 103      (:foreground "green"))
 104     (((class color)
 105       (background dark))
 106      (:foreground "LightSkyBlue" :bold t))
 107     (((class color)
 108       (background light))
 109      (:foreground "purple" :bold t)))
 110   "Face used for displaying header content."
 111   :group 'wl-message-faces
 112   :group 'wl-faces)
 113
 114 (wl-defface wl-highlight-message-important-header-contents
 115   '(
 116     (((type tty)
 117       (background dark))
 118      (:foreground "yellow"))
 119     (((class color)
 120       (background dark))
 121      (:foreground "yellow" :bold t))
 122     (((class color)
 123       (background light))
 124      (:foreground "brown" :bold t)))
 125   "Face used for displaying contents of special headers."
 126   :group 'wl-message-faces
 127   :group 'wl-faces)
 128
 129 (wl-defface wl-highlight-message-important-header-contents2
 130   '(
 131     (((type tty)
 132       (background dark))
 133      (:foreground "red"))
 134     (((class color)
 135       (background dark))
 136      (:foreground "orange" :bold t))
 137     (((class color)
 138       (background light))
 139      (:foreground "DarkSlateBlue" :bold t)))
 140   "Face used for displaying contents of special headers."
 141   :group 'wl-message-faces
 142   :group 'wl-faces)
 143
 144 (wl-defface wl-highlight-message-citation-header
 145   '(
 146     (((type tty)
 147       (background dark))
 148      (:foreground "cyan"))
 149     (((class color)
 150       (background dark))
 151      (:foreground "SkyBlue"))
 152     (((class color)
 153       (background light))
 154      (:foreground "DarkGreen")))
 155   "Face used for displaying header of quoted texts."
 156   :group 'wl-message-faces
 157   :group 'wl-faces)
 158
 159 (wl-defface wl-highlight-message-unimportant-header-contents
 160   '(
 161     (((type tty)
 162       (background dark))
 163      (:foreground "green"))
 164     (((class color)
 165       (background dark))
 166      (:foreground "GreenYellow" :bold t))
 167     (((class color)
 168       (background light))
 169      (:foreground "DarkGreen" :bold t)))
 170   "Face used for displaying contents of unimportant headers."
 171   :group 'wl-message-faces
 172   :group 'wl-faces)
 173
 174 (wl-defface wl-highlight-message-signature
 175   '((((class color)
 176       (background dark))
 177      (:foreground "khaki"))
 178     (((class color)
 179       (background light))
 180      (:foreground "DarkSlateBlue")))
 181   "Face used for displaying signature."
 182   :group 'wl-message-faces
 183   :group 'wl-faces)
 184
 185 ;; for draft
 186
 187 (wl-defface wl-highlight-header-separator-face
 188   '(
 189     (((type tty)
 190       (background dark))
 191      (:foreground "black" :background "yellow"))
 192     (((class color))
 193      (:foreground "Black" :background "DarkKhaki")))
 194   "Face used for displaying header separator."
 195   :group 'wl-draft
 196   :group 'wl-faces)
 197
 198 ;; important messages
 199
 200 (wl-defface wl-highlight-summary-important-face
 201   '(
 202     (((type tty)
 203       (background dark))
 204      (:foreground "magenta"))
 205     (((class color)
 206       (background dark))
 207      (:foreground "orange"))
 208     (((class color)
 209       (background light))
 210      (:foreground "purple")))
 211   "Face used for displaying important messages."
 212   :group 'wl-summary-faces
 213   :group 'wl-faces)
 214
 215 (wl-defface wl-highlight-summary-new-face
 216   '(
 217     (((type tty)
 218       (background dark))
 219      (:foreground "red"))
 220     (((class color)
 221       (background dark))
 222      (:foreground "tomato"))
 223     (((class color)
 224       (background light))
 225      (:foreground "tomato")))
 226   "Face used for displaying new messages."
 227   :group 'wl-summary-faces
 228   :group 'wl-faces)
 229
 230 (wl-defface wl-highlight-summary-displaying-face
 231   '((t
 232      (:underline t :bold t)))
 233   "Face used for displaying message."
 234   :group 'wl-summary-faces
 235   :group 'wl-faces)
 236
 237 (wl-defface wl-highlight-thread-indent-face
 238   '((t
 239      (:foreground "gray40")))
 240   "Face used for displaying indented thread."
 241   :group 'wl-summary-faces
 242   :group 'wl-faces)
 243
 244 ;; unimportant messages
 245
 246 (wl-defface wl-highlight-summary-unread-face
 247   '(
 248     (((type tty)
 249       (background dark))
 250      (:foreground "cyan"))
 251     (((class color)
 252       (background dark))
 253      (:foreground "LightSkyBlue"))
 254     (((class color)
 255       (background light))
 256      (:foreground "RoyalBlue")))
 257   "Face used for displaying unread messages."
 258   :group 'wl-summary-faces
 259   :group 'wl-faces)
 260
 261 (wl-defface wl-highlight-summary-deleted-face
 262   '(
 263     (((type tty)
 264       (background dark))
 265      (:foreground "blue"))
 266     (((class color)
 267       (background dark))
 268      (:foreground "gray"))
 269     (((class color)
 270       (background light))
 271      (:foreground "DarkKhaki")))
 272   "Face used for displaying messages mark as deleted."
 273   :group 'wl-summary-faces
 274   :group 'wl-faces)
 275
 276 (wl-defface wl-highlight-summary-refiled-face
 277   '(
 278     (((type tty)
 279       (background dark))
 280      (:foreground "blue"))
 281     (((class color)
 282       (background dark))
 283      (:foreground "blue"))
 284     (((class color)
 285       (background light))
 286      (:foreground "firebrick")))
 287   "Face used for displaying messages mark as refiled."
 288   :group 'wl-summary-faces
 289   :group 'wl-faces)
 290
 291 (wl-defface wl-highlight-summary-copied-face
 292   '(
 293     (((type tty)
 294       (background dark))
 295      (:foreground "blue"))
 296     (((class color)
 297       (background dark))
 298      (:foreground "cyan"))
 299     (((class color)
 300       (background light))
 301      (:foreground "blue")))
 302   "Face used for displaying messages mark as copied."
 303   :group 'wl-summary-faces
 304   :group 'wl-faces)
 305
 306 ;; obsolete.
 307 (wl-defface wl-highlight-summary-temp-face
 308   '(
 309     (((type tty)
 310       (background dark))
 311      (:foreground "gold"))
 312     (((class color))
 313      (:foreground "HotPink1")))
 314   "Face used for displaying messages mark as temp."
 315   :group 'wl-summary-faces
 316   :group 'wl-faces)
 317
 318 (wl-defface wl-highlight-summary-target-face
 319   '(
 320     (((type tty)
 321       (background dark))
 322      (:foreground "gold"))
 323     (((class color))
 324      (:foreground "HotPink1")))
 325   "Face used for displaying messages mark as target."
 326   :group 'wl-summary-faces
 327   :group 'wl-faces)
 328
 329 (wl-defface wl-highlight-summary-low-read-face
 330   '(
 331     (((type tty)
 332       (background dark))
 333      (:foreground "yellow" :italic t))
 334     (((class color)
 335       (background dark))
 336      (:foreground "PaleGreen" :italic t))
 337     (((class color)
 338       (background light))
 339      (:foreground "Green3" :italic t)))
 340   "Face used for displaying low interest read messages."
 341   :group 'wl-summary-faces
 342   :group 'wl-faces)
 343
 344 (wl-defface wl-highlight-summary-high-read-face
 345   '(
 346     (((type tty))
 347      (:bold t))
 348     (((class color)
 349       (background dark))
 350      (:foreground "PaleGreen" :bold t))
 351     (((class color)
 352       (background light))
 353      (:foreground "SeaGreen" :bold t)))
 354   "Face used for displaying high interest read messages."
 355   :group 'wl-summary-faces
 356   :group 'wl-faces)
 357
 358 (wl-defface wl-highlight-summary-low-unread-face
 359   '(
 360     (((type tty)
 361       (background dark))
 362      (:foreground "cyan" :italic t))
 363     (((class color)
 364       (background dark))
 365      (:foreground "LightSkyBlue" :italic t))
 366     (((class color)
 367       (background light))
 368      (:foreground "RoyalBlue" :italic t)))
 369   "Face used for displaying low interest unread messages."
 370   :group 'wl-summary-faces
 371   :group 'wl-faces)
 372
 373 (wl-defface wl-highlight-summary-high-unread-face
 374   '(
 375     (((type tty))
 376      (:foreground "red" :bold t))
 377     (((class color)
 378       (background dark))
 379      (:foreground "tomato" :bold t))
 380     (((class color)
 381       (background light))
 382      (:foreground "tomato" :bold t)))
 383   "Face used for displaying high interest unread messages."
 384   :group 'wl-summary-faces
 385   :group 'wl-faces)
 386
 387 ;; ordinary messages
 388
 389 (wl-defface wl-highlight-summary-thread-top-face
 390   '(
 391     (((type tty)
 392       (background dark))
 393      (:foreground "green"))
 394     (((class color)
 395       (background dark))
 396      (:foreground "GreenYellow"))
 397     (((class color)
 398       (background light))
 399      (:foreground "green4")))
 400   "Face used for displaying top thread message."
 401   :group 'wl-summary-faces
 402   :group 'wl-faces)
 403
 404 (wl-defface wl-highlight-summary-normal-face
 405   '(
 406     (((type tty)
 407       (background dark))
 408      (:foreground "yellow"))
 409     (((class color)
 410       (background dark))
 411      (:foreground "PaleGreen"))
 412     (((class color)
 413       (background light))
 414      (:foreground "SeaGreen")))
 415   "Face used for displaying normal message."
 416   :group 'wl-summary-faces
 417   :group 'wl-faces)
 418
 419 ;; folder
 420
 421 (wl-defface wl-highlight-folder-unknown-face
 422   '(
 423     (((type tty)
 424       (background dark))
 425      (:foreground "cyan"))
 426     (((class color)
 427       (background dark))
 428      (:foreground "pink"))
 429     (((class color)
 430       (background light))
 431      (:foreground "RoyalBlue")))
 432   "Face used for displaying unread folder."
 433   :group 'wl-folder-faces
 434   :group 'wl-faces)
 435
 436 (wl-defface wl-highlight-folder-killed-face
 437   '(
 438     (((type tty)
 439       (background dark))
 440      (:foreground "gray"))
 441     (((class color))
 442      (:foreground "gray50")))
 443   "Face used for displaying killed folder."
 444   :group 'wl-folder-faces
 445   :group 'wl-faces)
 446
 447 (wl-defface wl-highlight-folder-zero-face
 448   '(
 449     (((type tty)
 450       (background dark))
 451      (:foreground "green"))
 452     (((class color)
 453       (background dark))
 454      (:foreground "SkyBlue"))
 455     (((class color)
 456       (background light))
 457      (:foreground "BlueViolet")))
 458   "Face used for displaying folder needs no sync."
 459   :group 'wl-folder-faces
 460   :group 'wl-faces)
 461
 462 (wl-defface wl-highlight-folder-few-face
 463   '(
 464     (((type tty)
 465       (background dark))
 466      (:foreground "yellow"))
 467     (((class color)
 468       (background dark))
 469      (:foreground "orange"))
 470     (((class color)
 471       (background light))
 472      (:foreground "OrangeRed3")))
 473   "Face used for displaying folder contains few unsync messages."
 474   :group 'wl-folder-faces
 475   :group 'wl-faces)
 476
 477 (wl-defface wl-highlight-folder-many-face
 478   '(
 479     (((type tty)
 480       (background dark))
 481      (:foreground "red"))
 482     (((class color)
 483       (background dark))
 484      (:foreground "HotPink1"))
 485     (((class color)
 486       (background light))
 487      (:foreground "tomato")))
 488   "Face used for displaying folder contains many unsync messages."
 489   :group 'wl-folder-faces
 490   :group 'wl-faces)
 491
 492 (wl-defface wl-highlight-folder-unread-face
 493   '(
 494     (((type tty)
 495       (background dark))
 496      (:foreground "magenta"))
 497     (((class color)
 498       (background dark))
 499      (:foreground "gold"))
 500     (((class color)
 501       (background light))
 502      (:foreground "MediumVioletRed")))
 503   "Face used for displaying unread folder."
 504   :group 'wl-folder-faces
 505   :group 'wl-faces)
 506
 507 (wl-defface wl-highlight-folder-opened-face
 508   '(
 509     (((type tty)
 510       (background dark))
 511      (:foreground "blue"))
 512     (((class color)
 513       (background dark))
 514      (:foreground "PaleGreen"))
 515     (((class color)
 516       (background light))
 517      (:foreground "ForestGreen")))
 518   "Face used for displaying opened group folder."
 519   :group 'wl-folder-faces
 520   :group 'wl-faces)
 521
 522 (wl-defface wl-highlight-folder-closed-face
 523   '(
 524     (((type tty)
 525       (background dark))
 526      (:foreground "cyan"))
 527     (((class color)
 528       (background dark))
 529      (:foreground "GreenYellow"))
 530     (((class color)
 531       (background light))
 532      (:foreground "DarkOliveGreen4")))
 533   "Face used for displaying closed group folder."
 534   :group 'wl-folder-faces
 535   :group 'wl-faces)
 536
 537 (wl-defface wl-highlight-folder-path-face
 538   '((t
 539      (:bold t :underline t)))
 540   "Face used for displaying path."
 541   :group 'wl-folder-faces
 542   :group 'wl-faces)
 543
 544 (wl-defface wl-highlight-demo-face
 545   '(
 546     (((type tty)
 547       (background dark))
 548      (:foreground "green"))
 549     (((class color)
 550       (background dark))
 551      (:foreground "GreenYellow"))
 552     (((class color)
 553       (background light))
 554      (:foreground "blue2")))
 555   "Face used for displaying demo."
 556   :group 'wl-faces)
 557
 558 (wl-defface wl-highlight-logo-face
 559   '(
 560     (((type tty)
 561       (background dark))
 562      (:foreground "cyan"))
 563     (((class color)
 564       (background dark))
 565      (:foreground "SkyBlue"))
 566     (((class color)
 567       (background light))
 568      (:foreground "SteelBlue")))
 569   "Face used for displaying demo."
 570   :group 'wl-faces)
 571
 572 (wl-defface wl-highlight-refile-destination-face
 573   '((((class color)
 574       (background dark))
 575      (:foreground "pink"))
 576     (((class color)
 577       (background light))
 578      (:foreground "red")))
 579   "Face used for displaying refile destination."
 580   :group 'wl-summary-faces
 581   :group 'wl-faces)
 582
 583 ;; cited face
 584
 585 (wl-defface wl-highlight-message-cited-text-1
 586   '(
 587     (((type tty)
 588       (background dark))
 589      (:foreground "magenta"))
 590     (((class color)
 591       (background dark))
 592      (:foreground "HotPink1"))
 593     (((class color)
 594       (background light))
 595      (:foreground "ForestGreen")))
 596   "Face used for displaying quoted text from other messages."
 597   :group 'wl-message-faces
 598   :group 'wl-faces)
 599
 600 (wl-defface wl-highlight-message-cited-text-2
 601   '(
 602     (((type tty)
 603       (background dark))
 604      (:foreground "blue"))
 605     (((class color))
 606      (:foreground "violet")))
 607   "Face used for displaying quoted text from other messages."
 608   :group 'wl-message-faces
 609   :group 'wl-faces)
 610
 611 (wl-defface wl-highlight-message-cited-text-3
 612   '(
 613     (((type tty)
 614       (background dark))
 615      (:foreground "cyan"))
 616     (((class color))
 617      (:foreground "orchid3")))
 618   "Face used for displaying quoted text from other messages."
 619   :group 'wl-message-faces
 620   :group 'wl-faces)
 621
 622 (wl-defface wl-highlight-message-cited-text-4
 623   '(
 624     (((type tty)
 625       (background dark))
 626      (:foreground "green"))
 627     (((class color))
 628      (:foreground "purple1")))
 629   "Face used for displaying quoted text from other messages."
 630   :group 'wl-message-faces
 631   :group 'wl-faces)
 632
 633 (wl-defface wl-highlight-message-cited-text-5
 634   '(
 635     (((type tty)
 636       (background dark))
 637      (:foreground "yellow"))
 638     (((class color))
 639      (:foreground "MediumPurple1")))
 640   "Face used for displaying quoted text from other messages."
 641   :group 'wl-message-faces
 642   :group 'wl-faces)
 643
 644 (wl-defface wl-highlight-message-cited-text-6
 645   '(
 646     (((type tty)
 647       (background dark))
 648      (:foreground "red"))
 649     (((class color))
 650      (:foreground "PaleVioletRed")))
 651   "Face used for displaying quoted text from other messages."
 652   :group 'wl-message-faces
 653   :group 'wl-faces)
 654
 655 (wl-defface wl-highlight-message-cited-text-7
 656   '(
 657     (((type tty)
 658       (background dark))
 659      (:foreground "magenta"))
 660     (((class color))
 661      (:foreground "LightPink")))
 662   "Face used for displaying quoted text from other messages."
 663   :group 'wl-message-faces
 664   :group 'wl-faces)
 665
 666 (wl-defface wl-highlight-message-cited-text-8
 667   '(
 668     (((type tty)
 669       (background dark))
 670      (:foreground "blue"))
 671     (((class color))
 672      (:foreground "salmon")))
 673   "Face used for displaying quoted text from other messages."
 674   :group 'wl-message-faces
 675   :group 'wl-faces)
 676
 677 (wl-defface wl-highlight-message-cited-text-9
 678   '(
 679     (((type tty)
 680       (background dark))
 681      (:foreground "cyan"))
 682     (((class color))
 683      (:foreground "SandyBrown")))
 684   "Face used for displaying quoted text from other messages."
 685   :group 'wl-message-faces
 686   :group 'wl-faces)
 687
 688 (wl-defface wl-highlight-message-cited-text-10
 689   '(
 690     (((type tty)
 691       (background dark))
 692      (:foreground "green"))
 693     (((class color))
 694      (:foreground "wheat")))
 695   "Face used for displaying quoted text from other messages."
 696   :group 'wl-message-faces
 697   :group 'wl-faces)
 698
 699 (defvar wl-highlight-folder-opened-regexp " *\\(\\[\\-\\]\\)")
 700 (defvar wl-highlight-folder-closed-regexp " *\\(\\[\\+\\]\\)")
 701 (defvar wl-highlight-folder-leaf-regexp "[ ]*\\([-%\\+]\\)\\(.*\\):.*$")
 702
 703 (defvar wl-highlight-summary-unread-regexp " *[0-9]+[^0-9]\\(!\\|U\\)")
 704 (defvar wl-highlight-summary-important-regexp " *[0-9]+[^0-9]\\$")
 705 (defvar wl-highlight-summary-new-regexp " *[0-9]+[^0-9]N")
 706 (defvar wl-highlight-summary-deleted-regexp " *[0-9]+D")
 707 (defvar wl-highlight-summary-refiled-regexp " *[0-9]+o")
 708 (defvar wl-highlight-summary-copied-regexp " *[0-9]+O")
 709 (defvar wl-highlight-summary-target-regexp " *[0-9]+\\*")
 710 ;;(defvar wl-highlight-summary-thread-top-regexp " *[0-9]+[^0-9][^0-9]../..\(.*\)..:.. \\[")
 711
 712 (defvar wl-highlight-citation-face-list
 713   '(wl-highlight-message-cited-text-1
 714     wl-highlight-message-cited-text-2
 715     wl-highlight-message-cited-text-3
 716     wl-highlight-message-cited-text-4
 717     wl-highlight-message-cited-text-5
 718     wl-highlight-message-cited-text-6
 719     wl-highlight-message-cited-text-7
 720     wl-highlight-message-cited-text-8
 721     wl-highlight-message-cited-text-9
 722     wl-highlight-message-cited-text-10))
 723
 724 (defmacro defun-hilit (name &rest everything-else)
 725   "Define a function for highlight. Nemacs implementation is set as empty."
 726   (if wl-on-nemacs
 727       (` (defun (, name) nil nil))
 728     (` (defun (, name) (,@ everything-else)))))
 729
 730 (defmacro defun-hilit2 (name &rest everything-else)
 731   "Define a function for highlight w/o nemacs."
 732   (if wl-on-nemacs
 733       () ; noop
 734     (` (defun (, name) (,@ everything-else)))))
 735
 736 (defmacro wl-delete-all-overlays ()
 737   "Delete all momentary overlays."
 738   (if wl-on-nemacs
 739       nil
 740     '(let ((overlays (overlays-in (point-min) (point-max)))
 741            overlay)
 742        (while (setq overlay (car overlays))
 743          (if (overlay-get overlay 'wl-momentary-overlay)
 744              (delete-overlay overlay))
 745          (setq overlays (cdr overlays))))))
 746
 747 (defun-hilit wl-highlight-summary-displaying ()
 748   (interactive)
 749   (wl-delete-all-overlays)
 750   (let (bol eol ov)
 751     (save-excursion
 752       (beginning-of-line)
 753       (setq bol (point))
 754       (save-excursion (end-of-line) (setq eol (point)))
 755       (setq ov (make-overlay bol eol))
 756       (overlay-put ov 'face 'wl-highlight-summary-displaying-face)
 757       (overlay-put ov 'evaporate t)
 758       (overlay-put ov 'wl-momentary-overlay t))))
 759
 760 (defun-hilit2 wl-highlight-folder-group-line (numbers)
 761   (end-of-line)
 762   (let ((eol (point))
 763         bol)
 764     (beginning-of-line)
 765     (setq bol (point))
 766     (let ((text-face (cond ((looking-at wl-highlight-folder-opened-regexp)
 767                             'wl-highlight-folder-opened-face)
 768                            ((looking-at wl-highlight-folder-closed-regexp)
 769                             'wl-highlight-folder-closed-face))))
 770       (if (and wl-highlight-folder-by-numbers
 771                (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" eol t))
 772           (let* ((unsync (nth 0 numbers))
 773                  (unread (nth 1 numbers))
 774                  (face (cond ((and unsync (zerop unsync))
 775                               (if (and unread (> unread 0))
 776                                   'wl-highlight-folder-unread-face
 777                                 'wl-highlight-folder-zero-face))
 778                              ((and unsync
 779                                    (>= unsync wl-folder-many-unsync-threshold))
 780                               'wl-highlight-folder-many-face)
 781                              (t
 782                               'wl-highlight-folder-few-face))))
 783             (if (numberp wl-highlight-folder-by-numbers)
 784                 (progn
 785                   (put-text-property bol (match-beginning 0) 'face text-face)
 786                   (put-text-property (match-beginning 0) (match-end 0)
 787                                      'face face))
 788               ;; Remove previous face.
 789               (put-text-property bol (match-end 0) 'face nil)
 790               (put-text-property bol (match-end 0) 'face face)))
 791         (put-text-property bol eol 'face text-face)))))
 792
 793 (defun-hilit2 wl-highlight-summary-line-string (line mark temp-mark indent)
 794   (let (fsymbol)
 795     (cond ((and (string= temp-mark "+")
 796                 (member mark (list wl-summary-unread-cached-mark
 797                                    wl-summary-unread-uncached-mark
 798                                    wl-summary-new-mark)))
 799            (setq fsymbol 'wl-highlight-summary-high-unread-face))
 800           ((and (string= temp-mark "-")
 801                 (member mark (list wl-summary-unread-cached-mark
 802                                    wl-summary-unread-uncached-mark
 803                                    wl-summary-new-mark)))
 804            (setq fsymbol 'wl-highlight-summary-low-unread-face))
 805           ((string= temp-mark "o")
 806            (setq fsymbol 'wl-highlight-summary-refiled-face))
 807           ((string= temp-mark "O")
 808            (setq fsymbol 'wl-highlight-summary-copied-face))
 809           ((string= temp-mark "D")
 810            (setq fsymbol 'wl-highlight-summary-deleted-face))
 811           ((string= temp-mark "*")
 812            (setq fsymbol 'wl-highlight-summary-temp-face))
 813           ((string= mark wl-summary-new-mark)
 814            (setq fsymbol 'wl-highlight-summary-new-face))
 815           ((member mark (list wl-summary-unread-cached-mark
 816                               wl-summary-unread-uncached-mark))
 817            (setq fsymbol 'wl-highlight-summary-unread-face))
 818           ((or (string= mark wl-summary-important-mark))
 819            (setq fsymbol 'wl-highlight-summary-important-face))
 820           ((string= temp-mark "-")
 821            (setq fsymbol 'wl-highlight-summary-low-read-face))
 822           ((string= temp-mark "+")
 823            (setq fsymbol 'wl-highlight-summary-high-read-face))
 824           (t (if (= 0 (length indent))
 825                  (setq fsymbol 'wl-highlight-summary-thread-top-face)
 826                (setq fsymbol 'wl-highlight-summary-normal-face))))
 827     (put-text-property 0 (length line) 'face fsymbol line))
 828   (if wl-use-highlight-mouse-line
 829       (put-text-property 0 (length line) 'mouse-face 'highlight line)))
 830
 831 (defun-hilit2 wl-highlight-summary-current-line (&optional smark regexp temp-too)
 832   (interactive)
 833   (save-excursion
 834     (let ((inhibit-read-only t)
 835           (case-fold-search nil) temp-mark status-mark
 836           (sregexp (concat
 837                     "^"
 838                     wl-summary-buffer-number-regexp
 839                     "\\(.\\)\\(.\\)../..\(.*\)..:.. \\("
 840                     wl-highlight-thread-indent-string-regexp
 841                     "\\)[[<]"))
 842           fregexp fsymbol bol eol matched thread-top looked-at)
 843       (beginning-of-line)
 844       (setq bol (point))
 845       (save-excursion (end-of-line) (setq eol (point)))
 846       (if smark
 847           (setq status-mark smark)
 848         (setq looked-at (looking-at sregexp))
 849         (setq status-mark (buffer-substring (match-beginning 2)
 850                                             (match-end 2))))
 851       (when temp-too
 852         (unless looked-at
 853           (setq looked-at (looking-at sregexp)))
 854         (when looked-at
 855           (setq temp-mark (buffer-substring (match-beginning 1)
 856                                             (match-end 1)))
 857           (cond
 858            ((string= temp-mark "*")
 859             (setq fsymbol 'wl-highlight-summary-temp-face))
 860            ((string= temp-mark "D")
 861             (setq fsymbol 'wl-highlight-summary-deleted-face))
 862            ((string= temp-mark "O")
 863             (setq fsymbol 'wl-highlight-summary-copied-face))
 864            ((string= temp-mark "o")
 865             (setq fsymbol 'wl-highlight-summary-refiled-face)))))
 866       (if (not fsymbol)
 867           (cond
 868            ((and (string= temp-mark "+")
 869                  (member status-mark (list wl-summary-unread-cached-mark
 870                                            wl-summary-unread-uncached-mark
 871                                            wl-summary-new-mark)))
 872             (setq fsymbol 'wl-highlight-summary-high-unread-face))
 873            ((and (string= temp-mark "-")
 874                  (member status-mark (list wl-summary-unread-cached-mark
 875                                            wl-summary-unread-uncached-mark
 876                                            wl-summary-new-mark)))
 877             (setq fsymbol 'wl-highlight-summary-low-unread-face))
 878            ((string= status-mark wl-summary-new-mark)
 879             (setq fsymbol 'wl-highlight-summary-new-face))
 880            ((member status-mark (list wl-summary-unread-cached-mark
 881                                       wl-summary-unread-uncached-mark))
 882             (setq fsymbol 'wl-highlight-summary-unread-face))
 883            ((string= status-mark wl-summary-important-mark)
 884             (setq fsymbol 'wl-highlight-summary-important-face))
 885            ;; score mark
 886            ((string= temp-mark "-")
 887             (setq fsymbol 'wl-highlight-summary-low-read-face))
 888            ((string= temp-mark "+")
 889             (setq fsymbol 'wl-highlight-summary-high-read-face))
 890            ;;
 891            (t (if (and looked-at
 892                        (string= (buffer-substring
 893                                  (match-beginning 3)
 894                                  (match-end 3)) ""))
 895                   (setq fsymbol 'wl-highlight-summary-thread-top-face)
 896                 (setq fsymbol 'wl-highlight-summary-normal-face)))))
 897       (put-text-property bol eol 'face fsymbol)
 898       (if wl-use-highlight-mouse-line
 899           (put-text-property bol
 900 ;;; Use bol instead of (1- (match-end 0))
 901 ;;;                          (1- (match-end 0))
 902                              eol 'mouse-face 'highlight))
 903 ;;;   (put-text-property (match-beginning 3) (match-end 3)
 904 ;;;                      'face 'wl-highlight-thread-indent-face)
 905       ;; Dnd stuff.
 906       (if wl-use-dnd
 907           (wl-dnd-set-drag-starter bol eol)))))
 908
 909 (defun-hilit2 wl-highlight-folder (start end)
 910   "Highlight folder between start and end.
 911 Faces used:
 912   wl-highlight-folder-unknown-face      unread messages
 913   wl-highlight-folder-zero-face         folder needs no sync
 914   wl-highlight-folder-few-face          folder contains few unsync messages
 915   wl-highlight-folder-many-face         folder contains many unsync messages
 916   wl-highlight-folder-opened-face       opened group folder
 917   wl-highlight-folder-closed-face       closed group folder
 918
 919 Variables used:
 920   wl-highlight-folder-opened-regexp     matches opened group folder
 921   wl-highlight-folder-closed-regexp     matches closed group folder
 922 "
 923   (interactive "r")
 924   (if (< end start)
 925       (let ((s start)) (setq start end end s)))
 926   (let* ((lines (count-lines start end))
 927          (real-end end)
 928          gc-message)
 929     (save-excursion
 930       (save-restriction
 931         (widen)
 932         (narrow-to-region start end)
 933         (save-restriction
 934           (goto-char start)
 935           (while (not (eobp))
 936             (wl-highlight-folder-current-line)
 937             (forward-line 1)))))))
 938
 939 (defun-hilit2 wl-highlight-folder-path (folder-path)
 940   "Highlight current folder path...overlay"
 941   (save-excursion
 942     (wl-delete-all-overlays)
 943     (let ((fp folder-path) ov)
 944       (goto-char (point-min))
 945       (while (and fp
 946                   (not (eobp)))
 947         (beginning-of-line)
 948         (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
 949             (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
 950         (when (equal
 951                (get-text-property (point) 'wl-folder-entity-id)
 952                (car fp))
 953           (setq fp (cdr fp))
 954           (setq ov (make-overlay
 955                     (match-beginning 1)
 956                     (match-end 1)))
 957           (setq wl-folder-buffer-cur-point (point))
 958           (overlay-put ov 'face 'wl-highlight-folder-path-face)
 959           (overlay-put ov 'evaporate t)
 960           (overlay-put ov 'wl-momentary-overlay t))
 961         (forward-line 1)))))
 962
 963 (defun-hilit2 wl-highlight-refile-destination-string (string)
 964   (put-text-property 0 (length string) 'face
 965                      'wl-highlight-refile-destination-face
 966                      string))
 967
 968 (defun-hilit wl-highlight-summary-all ()
 969   "For evaluation"
 970   (interactive)
 971   (wl-highlight-summary (point-min)(point-max)))
 972
 973 (defun-hilit2 wl-highlight-summary (start end)
 974   "Highlight summary between start and end.
 975 Faces used:
 976   wl-highlight-summary-unread-face      unread messages
 977   wl-highlight-summary-important-face   important messages
 978   wl-highlight-summary-deleted-face     messages mark as deleted
 979   wl-highlight-summary-refiled-face     messages mark as refiled
 980   wl-highlight-summary-copied-face      messages mark as copied
 981   wl-highlight-summary-new-face         new messages
 982
 983 Variables used:
 984   wl-highlight-summary-unread-regexp    matches unread messages
 985   wl-highlight-summary-important-regexp matches important messages
 986   wl-highlight-summary-deleted-regexp   matches messages mark as deleted
 987   wl-highlight-summary-refiled-regexp   matches messages mark as refiled
 988   wl-highlight-summary-copied-regexp    matches messages mark as copied
 989   wl-highlight-summary-new-regexp       matches new messages
 990
 991 If HACK-SIG is true,then we search backward from END for something that
 992 looks like the beginning of a signature block, and don't consider that a
 993 part of the message (this is because signatures are often incorrectly
 994 interpreted as cited text.)"
 995   (if (< end start)
 996       (let ((s start)) (setq start end end s)))
 997   (let* ((lines (count-lines start end))
 998          (too-big (and wl-highlight-max-summary-lines
 999                        (> lines wl-highlight-max-summary-lines)))
1000          (real-end end)
1001          gc-message
1002          e p hend i percent)
1003     (save-excursion
1004       (save-restriction
1005         (widen)
1006         (narrow-to-region start end)
1007         (if (not too-big)
1008             (save-restriction
1009               (goto-char start)
1010               (setq i 0)
1011               (while (not (eobp))
1012                 (wl-highlight-summary-current-line nil nil wl-summary-scored)
1013                 (when (> lines elmo-display-progress-threshold)
1014                   (setq i (+ i 1))
1015                   (setq percent (/ (* i 100) lines))
1016                   (if (or (eq (% percent 5) 0) (= i lines))
1017                       (elmo-display-progress
1018                        'wl-highlight-summary "Highlighting..."
1019                        percent)))
1020                 (forward-line 1))
1021               (message "Highlighting...done")))))))
1022
1023 (defun wl-highlight-headers (&optional for-draft)
1024   (let ((beg (point-min))
1025         (end (or (save-excursion (re-search-forward "^$" nil t)
1026                                  (point))
1027                  (point-max))))
1028     (wl-highlight-message beg end nil)
1029     (unless for-draft
1030       (wl-highlight-message-add-buttons-to-header beg end)
1031       (and wl-highlight-x-face-func
1032            (funcall wl-highlight-x-face-func beg end)))
1033     (run-hooks 'wl-highlight-headers-hook)))
1034
1035 (defun wl-highlight-message-add-buttons-to-header (start end)
1036   (save-excursion
1037     (save-restriction
1038       (narrow-to-region start end)
1039       (let ((case-fold-search t)
1040             (alist wl-highlight-message-header-button-alist)
1041             entry)
1042         (while alist
1043           (setq entry (car alist)
1044                 alist (cdr alist))
1045           (goto-char (point-min))
1046           (while (re-search-forward (car entry) nil t)
1047             (setq start (match-beginning 0)
1048                   end (if (re-search-forward "^[^ \t]" nil t)
1049                           (match-beginning 0)
1050                         (point-max)))
1051             (goto-char start)
1052             (while (re-search-forward (nth 1 entry) end t)
1053               (goto-char (match-end 0))
1054               (wl-message-add-button
1055                (match-beginning (nth 2 entry))
1056                (match-end (nth 2 entry))
1057                (nth 3 entry) (match-string (nth 4 entry))))
1058             (goto-char end)))))))
1059
1060 (defun wl-highlight-body-all ()
1061   (wl-highlight-message (point-min) (point-max) t t))
1062
1063 (defun-hilit wl-highlight-body ()
1064   (let ((beg (or (save-excursion (goto-char (point-min))
1065                                  (re-search-forward "^$" nil t))
1066                  (point-min)))
1067         (end (point-max)))
1068     (wl-highlight-message beg end t)))
1069
1070 (defun-hilit2 wl-highlight-body-region (beg end)
1071   (wl-highlight-message beg end t t))
1072
1073 (defun wl-highlight-signature-search-simple (beg end)
1074   "Search signature area in the body message between BEG and END.
1075 Returns start point of signature."
1076   (save-excursion
1077     (goto-char end)
1078     (if (re-search-backward "\n--+ *\n" beg t)
1079         (if (eq (char-after (point)) ?\n)
1080             (1+ (point))
1081           (point))
1082       end)))
1083
1084 (defun wl-highlight-signature-search (beg end)
1085   "Search signature area in the body message between BEG and END.
1086 Returns start point of signature."
1087   (save-excursion
1088     (goto-char end)
1089     (or
1090      ;; look for legal signature separator (check at first for fasten)
1091      (re-search-backward "\n-- \n" beg t)
1092
1093      ;; look for dual separator
1094      (save-excursion
1095        (and
1096         (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1097         (> (- (match-end 0) (match-beginning 0)) 10);; "10" is a magic number.
1098         (re-search-backward
1099          (concat "^"
1100                  (regexp-quote (buffer-substring (match-beginning 0) (match-end 0)))
1101                  "$") beg t)))
1102
1103      ;; look for user specified signature-separator
1104      (if (stringp wl-highlight-signature-separator)
1105          (re-search-backward wl-highlight-signature-separator nil t);; case one string
1106        (let ((sep wl-highlight-signature-separator))            ;; case list
1107          (while (and sep
1108                      (not (re-search-backward (car sep) beg t)))
1109            (setq sep (cdr sep)))
1110          (point)))      ;; if no separator found, returns end.
1111      )))
1112
1113 (defun-hilit2 wl-highlight-message (start end hack-sig &optional body-only)
1114   "Highlight message headers between start and end.
1115 Faces used:
1116   wl-highlight-message-headers                    the part before the colon
1117   wl-highlight-message-header-contents            the part after the colon
1118   wl-highlight-message-important-header-contents  contents of \"special\"
1119                                                   headers
1120   wl-highlight-message-important-header-contents2 contents of \"special\"
1121                                                   headers
1122   wl-highlight-message-unimportant-header-contents contents of unimportant
1123                                                    headers
1124   wl-highlight-message-cited-text                  quoted text from other
1125                                                    messages
1126   wl-highlight-message-citation-header             header of quoted texts
1127   wl-highlight-message-signature                   signature
1128
1129 Variables used:
1130   wl-highlight-important-header-regexp   what makes a \"special\" header
1131   wl-highlight-important-header2-regexp  what makes a \"special\" header
1132   wl-highlight-unimportant-header-regexp what makes a \"special\" header
1133   wl-highlight-citation-prefix-regexp    matches lines of quoted text
1134   wl-highlight-citation-header-regexp    matches headers for quoted text
1135
1136 If HACK-SIG is true,then we search backward from END for something that
1137 looks like the beginning of a signature block, and don't consider that a
1138 part of the message (this is because signatures are often incorrectly
1139 interpreted as cited text.)"
1140   (if (< end start)
1141       (let ((s start)) (setq start end end s)))
1142   (let ((too-big (and wl-highlight-max-message-size
1143                       (> (- end start)
1144                          wl-highlight-max-message-size)))
1145         (real-end end)
1146         current  beg
1147         e p hend)
1148     (if too-big
1149         nil
1150       (save-excursion
1151         (save-restriction
1152           (widen)
1153           ;; take off signature
1154           (if (and hack-sig (not too-big))
1155               (setq end (funcall wl-highlight-signature-search-func
1156                                  (- end wl-max-signature-size) end)))
1157           (if hack-sig
1158               (put-text-property end (point-max)
1159                                  'face 'wl-highlight-message-signature))
1160           (narrow-to-region start end)
1161           (save-restriction
1162             ;; narrow down to just the headers...
1163             (goto-char start)
1164             ;; If this search fails then the narrowing performed above
1165             ;; is sufficient
1166             (if (re-search-forward (format
1167                                     "^$\\|%s"
1168                                     (regexp-quote mail-header-separator))
1169                                    nil t)
1170                 (narrow-to-region (point-min) (point)))
1171             ;; highlight only when header is not too-big.
1172             (when (or (null wl-highlight-max-header-size)
1173                       (< (point) wl-highlight-max-header-size))
1174               (goto-char start)
1175               (while (and (not body-only)
1176                           (not (eobp)))
1177                 (cond
1178                  ((looking-at "^[^ \t\n:]+[ \t]*:")
1179                   (put-text-property (match-beginning 0) (match-end 0)
1180                                      'face 'wl-highlight-message-headers)
1181                   (setq p (match-end 0))
1182                   (setq hend (save-excursion (std11-field-end end)))
1183                   (cond
1184                    ((catch 'match
1185                       (let ((regexp-alist wl-highlight-message-header-alist))
1186                         (while regexp-alist
1187                           (when (save-match-data
1188                                   (looking-at (caar regexp-alist)))
1189                             (put-text-property p hend 'face
1190                                                (cdar regexp-alist))
1191                             (throw 'match t))
1192                           (setq regexp-alist (cdr regexp-alist)))
1193                         (throw 'match nil))))
1194                    (t
1195                     (put-text-property
1196                      p hend 'face 'wl-highlight-message-header-contents)))
1197                   (goto-char hend))
1198                  ((looking-at mail-header-separator)
1199                   (put-text-property (match-beginning 0) (match-end 0)
1200                                      'face 'wl-highlight-header-separator-face)
1201                   (goto-char (match-end 0)))
1202                  ;; ignore non-header field name lines
1203                  (t (forward-line 1))))))
1204           (let (prefix prefix-face-alist pair end)
1205             (while (not (eobp))
1206               (cond
1207                ((null wl-highlight-force-citation-header-regexp)
1208                 nil)
1209                ((looking-at wl-highlight-force-citation-header-regexp)
1210                 (setq current 'wl-highlight-message-citation-header)
1211                 (setq end (match-end 0)))
1212                ((null wl-highlight-citation-prefix-regexp)
1213                 nil)
1214                ((looking-at wl-highlight-citation-prefix-regexp)
1215                 (setq prefix (buffer-substring (point)
1216                                                (match-end 0)))
1217                 (setq pair (assoc prefix prefix-face-alist))
1218                 (unless pair
1219                   (setq prefix-face-alist
1220                         (append prefix-face-alist
1221                                 (list
1222                                  (setq pair
1223                                        (cons
1224                                         prefix
1225                                         (nth
1226                                          (% (length prefix-face-alist)
1227                                             (length
1228                                              wl-highlight-citation-face-list))
1229                                          wl-highlight-citation-face-list)))))))
1230                 (unless wl-highlight-highlight-citation-too
1231                   (goto-char (match-end 0)))
1232                 (setq current (cdr pair)))
1233                ((null wl-highlight-citation-header-regexp)
1234                 nil)
1235                ((looking-at wl-highlight-citation-header-regexp)
1236                 (setq current 'wl-highlight-message-citation-header)
1237                 (setq end (match-end 0)))
1238                (t (setq current nil)))
1239               (cond (current
1240                      (setq p (point))
1241                      (forward-line 1) ; this is to put the \n in the face too
1242                      (let ()
1243 ;;;                    ((inhibit-read-only t))
1244                        (put-text-property p (or end (point))
1245                                           'face current)
1246                        (setq end nil))
1247                      (forward-char -1)))
1248               (forward-line 1)))
1249           (run-hooks 'wl-highlight-message-hook))))))
1250
1251 ;; highlight-mouse-line for folder mode
1252
1253 (defun wl-highlight-folder-mouse-line ()
1254   (interactive)
1255   (let* ((end (save-excursion (end-of-line) (point)))
1256          (beg (progn
1257                 (re-search-forward "[^ ]" end t)
1258                 (1- (point))))
1259          (inhibit-read-only t))
1260     (put-text-property beg end 'mouse-face 'highlight)))
1261
1262 ;;; wl-highlight.el ends here