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