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