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 (autoload 'elmo-flag-folder-referrer "elmo-flag")
 865 (defun wl-highlight-flag-folder-help-echo (folder number)
 866   (let ((referer (elmo-flag-folder-referrer folder number)))
 867     (concat "The message exists in "
 868             (mapconcat
 869              (lambda (pair)
 870                    (concat (car pair) "/"
 871                            (number-to-string
 872                             (cdr pair))))
 873              referer ","))))
 874
 875 (defun wl-highlight-summary-line-help-echo (number beg end &optional string)
 876   (let ((type (elmo-folder-type-internal wl-summary-buffer-elmo-folder))
 877         message handler)
 878     (when (setq handler (cadr (assq type wl-highlight-summary-line-help-echo-alist)))
 879       (setq message
 880             (funcall handler wl-summary-buffer-elmo-folder number))
 881       (if message
 882           (put-text-property beg end 'help-echo
 883                              message
 884                              string)))))
 885
 886 (defun wl-highlight-summary-line-string (number line flags temp-mark indent)
 887   (let ((fsymbol (car (wl-highlight-summary-line-face-spec
 888                        flags
 889                        temp-mark
 890                        (> (length indent) 0)))))
 891     (put-text-property 0 (length line) 'face fsymbol line))
 892   (when wl-use-highlight-mouse-line
 893     (put-text-property 0 (length line) 'mouse-face 'highlight line))
 894   (when wl-highlight-summary-line-help-echo-alist
 895     (wl-highlight-summary-line-help-echo number 0 (length line) line)))
 896
 897 (defun wl-highlight-summary-current-line (&optional number flags)
 898   (interactive)
 899   (save-excursion
 900     (let ((inhibit-read-only t)
 901           (case-fold-search nil)
 902           (deactivate-mark nil)
 903           (number (or number (wl-summary-message-number)))
 904           bol eol spec)
 905       (end-of-line)
 906       (setq eol (point))
 907       (beginning-of-line)
 908       (setq bol (point))
 909       (setq spec (wl-highlight-summary-line-face-spec
 910                   (or flags
 911                       (elmo-message-flags wl-summary-buffer-elmo-folder
 912                                           number))
 913                   (wl-summary-temp-mark number)
 914                   (wl-thread-entity-get-parent-entity
 915                    (wl-thread-get-entity number))))
 916       (when (car spec)
 917         (put-text-property bol eol 'face (car spec)))
 918       (when (cdr spec)
 919         (put-text-property (next-single-property-change
 920                             (next-single-property-change
 921                              bol 'wl-summary-action-argument
 922                              nil eol)
 923                             'wl-summary-action-argument nil eol)
 924                            eol
 925                            'face
 926                            'wl-highlight-action-argument-face))
 927       (when wl-use-highlight-mouse-line
 928         (put-text-property bol eol 'mouse-face 'highlight))
 929       (when wl-highlight-summary-line-help-echo-alist
 930         (wl-highlight-summary-line-help-echo number bol eol))
 931       (when wl-use-dnd
 932         (wl-dnd-set-drag-starter bol eol)))))
 933
 934 (defun wl-highlight-folder (start end)
 935   "Highlight folder between start and end.
 936 Faces used:
 937   wl-highlight-folder-unknown-face      unread messages
 938   wl-highlight-folder-zero-face         folder needs no sync
 939   wl-highlight-folder-few-face          folder contains few unsync messages
 940   wl-highlight-folder-many-face         folder contains many unsync messages
 941   wl-highlight-folder-opened-face       opened group folder
 942   wl-highlight-folder-closed-face       closed group folder
 943
 944 Variables used:
 945   wl-highlight-folder-opened-regexp     matches opened group folder
 946   wl-highlight-folder-closed-regexp     matches closed group folder
 947 "
 948   (interactive "r")
 949   (if (< end start)
 950       (let ((s start)) (setq start end end s)))
 951   (let* ((lines (count-lines start end))
 952          (real-end end)
 953          gc-message)
 954     (save-excursion
 955       (save-restriction
 956         (widen)
 957         (narrow-to-region start end)
 958         (save-restriction
 959           (goto-char start)
 960           (while (not (eobp))
 961             (wl-highlight-folder-current-line)
 962             (forward-line 1)))))))
 963
 964 (defun wl-highlight-folder-path (folder-path)
 965   "Highlight current folder path...overlay"
 966   (save-excursion
 967     (wl-delete-all-overlays)
 968     (let ((fp folder-path) ov)
 969       (goto-char (point-min))
 970       (while (and fp
 971                   (not (eobp)))
 972         (beginning-of-line)
 973         (or (looking-at "^[ ]*\\[[\\+-]\\]\\(.+\\):.*\n")
 974             (looking-at "^[ ]*\\([^ \\[].+\\):.*\n"))
 975         (when (equal
 976                (get-text-property (point) 'wl-folder-entity-id)
 977                (car fp))
 978           (setq fp (cdr fp))
 979           (setq ov (make-overlay
 980                     (match-beginning 1)
 981                     (match-end 1)))
 982           (setq wl-folder-buffer-cur-point (point))
 983           (overlay-put ov 'face 'wl-highlight-folder-path-face)
 984           (overlay-put ov 'evaporate t)
 985           (overlay-put ov 'wl-momentary-overlay t))
 986         (forward-line 1)))))
 987
 988 (defun wl-highlight-action-argument-string (string)
 989   (put-text-property 0 (length string) 'face
 990                      'wl-highlight-action-argument-face
 991                      string))
 992
 993 (defun wl-highlight-summary-all ()
 994   "For evaluation"
 995   (interactive)
 996   (wl-highlight-summary (point-min)(point-max)))
 997
 998 (defun wl-highlight-summary (start end &optional lazy)
 999   "Highlight summary between start and end.
1000 Faces used:
1001   wl-highlight-summary-unread-face      unread messages
1002   wl-highlight-summary-deleted-face     messages mark as deleted
1003   wl-highlight-summary-refiled-face     messages mark as refiled
1004   wl-highlight-summary-copied-face      messages mark as copied
1005   wl-highlight-summary-new-face         new messages
1006   wl-highlight-summary-*-flag-face      flagged messages"
1007   (if (< end start)
1008       (let ((s start)) (setq start end end s)))
1009   (let (lines too-big gc-message e p hend i percent)
1010     (save-excursion
1011       (unless wl-summary-lazy-highlight
1012         (setq lines (count-lines start end)
1013               too-big (and wl-highlight-max-summary-lines
1014                            (> lines wl-highlight-max-summary-lines))))
1015       (goto-char start)
1016       (setq i 0)
1017       (while (and (not (eobp))
1018                   (< (point) end))
1019         (when (or (not lazy)
1020                   (null (get-text-property (point) 'face)))
1021           (wl-highlight-summary-current-line))
1022         (forward-line 1))
1023       (unless wl-summary-lazy-highlight
1024         (message "Highlighting...done")))))
1025
1026 (defun wl-highlight-summary-window (&optional win beg)
1027   "Highlight summary window.
1028 This function is defined for `window-scroll-functions'"
1029   (when wl-summary-highlight
1030     (with-current-buffer (window-buffer win)
1031       (when (eq major-mode 'wl-summary-mode)
1032         (let ((start (window-start win))
1033               (end (condition-case nil
1034                        (window-end win t) ;; old emacsen doesn't support 2nd arg.
1035                      (error (window-end win)))))
1036           (wl-highlight-summary start
1037                                 end
1038                                 'lazy))
1039         (set-buffer-modified-p nil)))))
1040
1041 (defun wl-highlight-headers (&optional for-draft)
1042   (let ((beg (point-min))
1043         (end (or (save-excursion (re-search-forward "^$" nil t)
1044                                  (point))
1045                  (point-max))))
1046     (wl-highlight-message beg end nil)
1047     (unless for-draft
1048       (when wl-highlight-x-face-function
1049         (funcall wl-highlight-x-face-function)))
1050     (run-hooks 'wl-highlight-headers-hook)))
1051
1052 (defun wl-highlight-body-all ()
1053   (wl-highlight-message (point-min) (point-max) t t))
1054
1055 (defun wl-highlight-body ()
1056   (let ((beg (or (save-excursion (goto-char (point-min))
1057                                  (re-search-forward "^$" nil t))
1058                  (point-min)))
1059         (end (point-max)))
1060     (wl-highlight-message beg end t)))
1061
1062 (defun wl-highlight-body-region (beg end)
1063   (wl-highlight-message beg end t t))
1064
1065 (defun wl-highlight-signature-search-simple (beg end)
1066   "Search signature area in the body message between BEG and END.
1067 Returns start point of signature."
1068   (save-excursion
1069     (goto-char end)
1070     (if (re-search-backward "\n--+ *\n" beg t)
1071         (if (eq (char-after (point)) ?\n)
1072             (1+ (point))
1073           (point))
1074       end)))
1075
1076 (defun wl-highlight-signature-search (beg end)
1077   "Search signature area in the body message between BEG and END.
1078 Returns start point of signature."
1079   (save-excursion
1080     (goto-char end)
1081     (or
1082      ;; look for legal signature separator (check at first for fasten)
1083      (search-backward "\n-- \n" beg t)
1084
1085      ;; look for dual separator
1086      (let ((pt (point))
1087            separator)
1088        (prog1
1089            (and (re-search-backward "^[^A-Za-z0-9> \t\n]+ *$" beg t)
1090                 ;; `10' is a magic number.
1091                 (> (- (match-end 0) (match-beginning 0)) 10)
1092                 (setq separator (buffer-substring (match-beginning 0)
1093                                                   (match-end 0)))
1094                 ;; We should not use `re-search-backward' for a long word
1095                 ;; since it is possible to crash XEmacs because of a bug.
1096                 (if (search-backward (concat "\n" separator "\n") beg t)
1097                     (1+ (point))
1098                   (and (search-backward (concat separator "\n") beg t)
1099                        (bolp)
1100                        (point))))
1101          (goto-char pt)))
1102
1103      ;; look for user specified signature-separator
1104      (if (stringp wl-highlight-signature-separator)
1105          (re-search-backward wl-highlight-signature-separator nil t);; case one string
1106        (let ((sep wl-highlight-signature-separator))            ;; case list
1107          (while (and sep
1108                      (not (re-search-backward (car sep) beg t)))
1109            (setq sep (cdr sep)))
1110          (point)))      ;; if no separator found, returns end.
1111      )))
1112
1113 (defun wl-highlight-message (start end hack-sig &optional body-only)
1114   "Highlight message headers between start and end.
1115 Faces used:
1116   wl-highlight-message-headers                    the part before the colon
1117   wl-highlight-message-header-contents            the part after the colon
1118   wl-highlight-message-important-header-contents  contents of \"important\"
1119                                                   headers
1120   wl-highlight-message-important-header-contents2 contents of \"important\"
1121                                                   headers
1122   wl-highlight-message-unimportant-header-contents contents of unimportant
1123                                                    headers
1124   wl-highlight-message-cited-text-N                quoted text from other
1125                                                    messages
1126   wl-highlight-message-citation-header             header of quoted texts
1127   wl-highlight-message-signature                   signature
1128
1129 Variables used:
1130   wl-highlight-message-header-alist             alist of header regexp with
1131                                                 face for header contents
1132   wl-highlight-citation-prefix-regexp           matches lines of quoted text
1133   wl-highlight-force-citation-header-regexp     matches headers for quoted text
1134   wl-highlight-citation-header-regexp           matches headers for quoted text
1135
1136 If HACK-SIG is true,then we search backward from END for something that
1137 looks like the beginning of a signature block, and don't consider that a
1138 part of the message (this is because signatures are often incorrectly
1139 interpreted as cited text.)"
1140   (if (< end start)
1141       (let ((s start)) (setq start end end s)))
1142   (let ((too-big (and wl-highlight-max-message-size
1143                       (> (- end start)
1144                          wl-highlight-max-message-size)))
1145         (real-end end)
1146         current  beg
1147         e p hend)
1148     (unless too-big
1149       (save-excursion
1150         (save-restriction
1151           (widen)
1152           ;; take off signature
1153           (if (and hack-sig (not too-big))
1154               (setq end (funcall wl-highlight-signature-search-function
1155                                  (- end wl-max-signature-size) end)))
1156           (if (and hack-sig
1157                    (not (eq end real-end)))
1158               (put-text-property end (point-max)
1159                                  'face 'wl-highlight-message-signature))
1160           (narrow-to-region start end)
1161           (save-restriction
1162             ;; narrow down to just the headers...
1163             (goto-char start)
1164             ;; If this search fails then the narrowing performed above
1165             ;; is sufficient
1166             (if (re-search-forward (format
1167                                     "^\\(%s\\)?$"
1168                                     (regexp-quote mail-header-separator))
1169                                    nil t)
1170                 (narrow-to-region (point-min) (match-beginning 0)))
1171             ;; highlight only when header is not too-big.
1172             (when (or (null wl-highlight-max-header-size)
1173                       (< (point) wl-highlight-max-header-size))
1174               (goto-char start)
1175               (while (and (not body-only)
1176                           (not (eobp)))
1177                 (if (looking-at "^[^ \t\n:]+[ \t]*:[ \t]*")
1178                     (progn
1179                       (put-text-property (match-beginning 0) (match-end 0)
1180                                          'face 'wl-highlight-message-headers)
1181                       (setq p (match-end 0))
1182                       (setq hend (save-excursion (std11-field-end end)))
1183                       (or (catch 'match
1184                             (let ((regexp-alist wl-highlight-message-header-alist))
1185                               (while regexp-alist
1186                                 (when (save-match-data
1187                                         (looking-at (caar regexp-alist)))
1188                                   (put-text-property p hend 'face
1189                                                      (cdar regexp-alist))
1190                                   (throw 'match t))
1191                                 (setq regexp-alist (cdr regexp-alist)))
1192                               (throw 'match nil)))
1193                           (put-text-property
1194                            p hend 'face 'wl-highlight-message-header-contents))
1195                       (goto-char hend))
1196                   ;; ignore non-header field name lines
1197                   (forward-line 1)))))
1198           (let (prefix prefix-face-alist pair end)
1199             (while (not (eobp))
1200               (cond
1201                ((looking-at (concat "^" (regexp-quote mail-header-separator) "$"))
1202                 (put-text-property (match-beginning 0) (match-end 0)
1203                                    'face 'wl-highlight-header-separator-face)
1204                 (goto-char (match-end 0)))
1205                ((null wl-highlight-force-citation-header-regexp)
1206                 nil)
1207                ((looking-at wl-highlight-force-citation-header-regexp)
1208                 (setq current 'wl-highlight-message-citation-header)
1209                 (setq end (match-end 0)))
1210                ((null wl-highlight-citation-prefix-regexp)
1211                 nil)
1212                ((looking-at wl-highlight-citation-prefix-regexp)
1213                 (setq prefix (buffer-substring (point)
1214                                                (match-end 0)))
1215                 (setq pair (assoc prefix prefix-face-alist))
1216                 (unless pair
1217                   (setq prefix-face-alist
1218                         (append prefix-face-alist
1219                                 (list
1220                                  (setq pair
1221                                        (cons
1222                                         prefix
1223                                         (nth
1224                                          (% (length prefix-face-alist)
1225                                             (length
1226                                              wl-highlight-citation-face-list))
1227                                          wl-highlight-citation-face-list)))))))
1228                 (unless wl-highlight-highlight-citation-too
1229                   (goto-char (match-end 0)))
1230                 (setq current (cdr pair)))
1231                ((null wl-highlight-citation-header-regexp)
1232                 nil)
1233                ((looking-at wl-highlight-citation-header-regexp)
1234                 (setq current 'wl-highlight-message-citation-header)
1235                 (setq end (match-end 0)))
1236                (t (setq current nil)))
1237               (cond (current
1238                      (setq p (point))
1239                      (forward-line 1) ; this is to put the \n in the face too
1240                      (let ()
1241 ;;;                    ((inhibit-read-only t))
1242                        (put-text-property p (or end (point))
1243                                           'face current)
1244                        (setq end nil))
1245                      (forward-char -1)))
1246               (forward-line 1)))
1247           (run-hooks 'wl-highlight-message-hook))))))
1248
1249 ;; highlight-mouse-line for folder mode
1250
1251 (defun wl-highlight-folder-mouse-line ()
1252   (interactive)
1253   (let* ((end (save-excursion (end-of-line) (point)))
1254          (beg (progn
1255                 (re-search-forward "[^ ]" end t)
1256                 (1- (point))))
1257          (inhibit-read-only t))
1258     (put-text-property beg end 'mouse-face 'highlight)))
1259
1260
1261 (require 'product)
1262 (product-provide (provide 'wl-highlight) (require 'wl-version))
1263
1264 ;;; wl-highlight.el ends here