wl/wl-highlight.el

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