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