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