wl/wl-highlight.el

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