wl/wl-highlight.el

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