wl/wl-highlight.el

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