wl/wl-highlight.el

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