wl/wl-highlight.el

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