wl/wl-e21.el

   1 ;;; wl-e21.el -- Wanderlust modules for Emacs 21.
   2
   3 ;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>
   4 ;; Copyright (C) 2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Katsumi Yamaoka <yamaoka@jpl.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 ;; This module uses `before-string' overlay property to show icon
  30 ;; images instead of `insert-image', so don't delete such overlays
  31 ;; sloppily.  Here is a sample code to show icons in the buffer.
  32 ;;
  33 ;;(let (image icon from to overlay)
  34 ;;  ;; The function `find-image' will look for an image first on `load-path'
  35 ;;  ;; and then in `data-directory'.
  36 ;;  (let ((load-path (cons wl-icon-dir load-path)))
  37 ;;    (setq image (find-image (list (list :type 'xpm :file wl-nntp-folder-icon
  38 ;;                                      :ascent 'center)))))
  39 ;;  ;; `propertize' is a convenient function in such a case.
  40 ;;  ;; String must have one or more length to wear an image.
  41 ;;  (setq icon (propertize "any string" 'display image))
  42 ;;  (pop-to-buffer (get-buffer-create "*wl-e21-demo*"))
  43 ;;  (erase-buffer)
  44 ;;  (insert "   ")
  45 ;;  (setq from (point))
  46 ;;  (insert "-fj.wanderlust:0/0/0")
  47 ;;  (setq to (point))
  48 ;;  (insert "\n")
  49 ;;  (setq overlay (make-overlay from to))
  50 ;;  ;; Put an image.
  51 ;;  (overlay-put overlay 'before-string icon)
  52 ;;  ;; Put a mark to indicate that this overlay is made by `wl-e21'.
  53 ;;  ;; It is not always necessarily.
  54 ;;  (overlay-put overlay 'wl-e21-icon t)
  55 ;;  ;; Make it to be removable.
  56 ;;  (overlay-put overlay 'evaporate t))
  57 ;;
  58 ;; Note that a port of Emacs to some platforms (e.g. MS-Windoze) does
  59 ;; not yet support images.  It is a pity that neither icons nor tool-
  60 ;; bars will not be displayed in such systems.
  61
  62 ;;; Code:
  63 ;;
  64
  65 (require 'elmo)
  66 (eval-when-compile
  67   (require 'wl-folder)
  68   (require 'wl-summary)
  69   (require 'wl-draft)
  70   (require 'wl-message)
  71   (require 'wl-highlight)
  72   (defvar-maybe wl-folder-mode-map (make-sparse-keymap))
  73   (defvar-maybe wl-draft-mode-map (make-sparse-keymap)))
  74
  75 ;; For Emacs 21.0.104 or earlier
  76 (defun-maybe make-mode-line-mouse-map (mouse function) "\
  77 Return a keymap with single entry for mouse key MOUSE on the mode line.
  78 MOUSE is defined to run function FUNCTION with no args in the buffer
  79 corresponding to the mode line clicked."
  80   (let ((map (make-sparse-keymap)))
  81     (define-key map (vector 'mode-line mouse) function)
  82     map))
  83
  84 (add-hook 'wl-folder-mode-hook 'wl-setup-folder)
  85 (add-hook 'wl-folder-mode-hook 'wl-folder-init-icons)
  86
  87 (add-hook 'wl-init-hook 'wl-biff-init-icons)
  88 (add-hook 'wl-init-hook 'wl-plugged-init-icons)
  89
  90 (add-hook 'wl-summary-mode-hook 'wl-setup-summary)
  91
  92 (defvar wl-use-toolbar (image-type-available-p 'xpm))
  93 (defvar wl-plugged-image nil)
  94 (defvar wl-unplugged-image nil)
  95 (defvar wl-biff-mail-image nil)
  96 (defvar wl-biff-nomail-image nil)
  97
  98 (defvar wl-folder-toolbar
  99   '([wl-folder-jump-to-current-entity
 100      wl-folder-jump-to-current-entity t "Enter Current Folder"]
 101     [wl-folder-next-entity
 102      wl-folder-next-entity t "Next Folder"]
 103     [wl-folder-prev-entity
 104      wl-folder-prev-entity t "Previous Folder"]
 105     [wl-folder-check-current-entity
 106      wl-folder-check-current-entity t "Check Current Folder"]
 107     ;;[wl-draft
 108     ;; wl-draft t "Write a New Message"]
 109     [wl-folder-sync-current-entity
 110      wl-folder-sync-current-entity t "Sync Current Folder"]
 111     [wl-draft
 112      wl-draft t "Write a New Message"]
 113     [wl-folder-empty-trash
 114      wl-folder-empty-trash t "Empty Trash"]
 115     [wl-exit
 116      wl-exit t "Quit Wanderlust"]
 117     )
 118   "The Folder buffer toolbar.")
 119
 120 (defvar wl-summary-toolbar
 121   '([wl-summary-read
 122      wl-summary-read t "Read Messages"]
 123     [wl-summary-next
 124      wl-summary-next t "Next Message"]
 125     [wl-summary-prev
 126      wl-summary-prev t "Previous Message"]
 127     [wl-summary-jump-to-current-message
 128      wl-summary-jump-to-current-message t "Jump to Current Message"]
 129     [wl-summary-sync-force-update
 130      wl-summary-sync-force-update t "Sync Current Folder"]
 131     [wl-summary-delete
 132      wl-summary-delete t "Delete Current Message"]
 133     [wl-summary-mark-as-important
 134      wl-summary-mark-as-important t "Mark Current Message as Important"]
 135     [wl-draft
 136      wl-draft t "Write a New Message"]
 137     [wl-summary-reply
 138      wl-summary-reply t "Reply to Current Message" ]
 139     [wl-summary-reply-with-citation
 140      wl-summary-reply-with-citation t "Reply to Current Message with Citation"]
 141     [wl-summary-forward
 142      wl-summary-forward t "Forward Current Message"]
 143     [wl-summary-exit
 144      wl-summary-exit t "Exit Current Summary"]
 145     )
 146   "The Summary buffer toolbar.")
 147
 148 (defvar wl-message-toolbar
 149   '([wl-message-read
 150      wl-message-read t "Read Contents"]
 151     [wl-message-next-content
 152      wl-message-next-content t "Next Content"]
 153     [wl-message-prev-content
 154      wl-message-prev-content t "Previous Content"]
 155     [wl-message-quit
 156      wl-message-quit t "Back to Summary"]
 157     [wl-message-play-content
 158      wl-message-play-content t "Play Content"]
 159     [wl-message-extract-content
 160      wl-message-extract-content t "Extract Content"]
 161     )
 162   "The Message buffer toolbar.")
 163
 164 (defalias 'wl-draft-insert-signature 'insert-signature);; for draft toolbar.
 165
 166 (defvar wl-draft-toolbar
 167   '([wl-draft-send-from-toolbar
 168      wl-draft-send-from-toolbar t "Send Current Draft"]
 169     [wl-draft-yank-original
 170      wl-draft-yank-original t "Yank Displaying Message"]
 171     [wl-draft-insert-signature
 172      wl-draft-insert-signature t "Insert Signature"]
 173     [wl-draft-kill
 174      wl-draft-kill t "Kill Current Draft"]
 175     )
 176   "The Draft buffer toolbar.")
 177
 178 (eval-when-compile
 179   (defmacro wl-e21-display-image-p ()
 180     '(and (display-graphic-p)
 181           (image-type-available-p 'xpm))))
 182
 183 (defun wl-e21-setup-toolbar (bar)
 184   (when (and wl-use-toolbar
 185              (wl-e21-display-image-p))
 186     (let ((load-path (cons wl-icon-dir load-path))
 187           (props '(:type xpm :ascent center
 188                          :color-symbols (("backgroundToolBarColor" . "None"))
 189                          :file))
 190           (success t)
 191           icon up down disabled name success)
 192       (while bar
 193         (setq icon (aref (pop bar) 0))
 194         (unless (boundp icon)
 195           (setq name (symbol-name icon)
 196                 up (find-image `((,@props ,(concat name "-up.xpm")))))
 197           (if up
 198               (progn
 199                 (setq down (find-image `((,@props ,(concat name "-down.xpm"))))
 200                       disabled (find-image
 201                                 `((,@props ,(concat name "-disabled.xpm")))))
 202                 (set icon (vector down up disabled disabled)))
 203             (setq bar nil
 204                   success nil))))
 205       success)))
 206
 207 (defvar wl-e21-toolbar-configurations
 208   '((auto-resize-tool-bar        . t)
 209     (auto-raise-tool-bar-buttons . t)
 210     (tool-bar-button-margin      . 0)
 211     (tool-bar-button-relief      . 2)))
 212
 213 (defun wl-e21-make-toolbar-buttons (keymap defs)
 214   (let ((configs wl-e21-toolbar-configurations)
 215         config)
 216     (while (setq config (pop configs))
 217       (set (make-local-variable (car config)) (cdr config))))
 218   ;; Invalidate the default bindings.
 219   (let ((keys (cdr (key-binding [tool-bar] t)))
 220         item)
 221     (while (setq item (pop keys))
 222       (when (setq item (car-safe item))
 223         (define-key keymap (vector 'tool-bar item) 'undefined))))
 224   (let ((n (length defs))
 225         def)
 226     (while (>= n 0)
 227       (setq n (1- n)
 228             def (nth n defs))
 229       (define-key keymap (vector 'tool-bar (aref def 1))
 230         (list 'menu-item (aref def 3) (aref def 1)
 231               :enable (aref def 2)
 232               :image (symbol-value (aref def 0)))))))
 233
 234 (defun wl-e21-setup-folder-toolbar ()
 235   (when (wl-e21-setup-toolbar wl-folder-toolbar)
 236     (wl-e21-make-toolbar-buttons wl-folder-mode-map wl-folder-toolbar)))
 237
 238 (defun wl-e21-setup-summary-toolbar ()
 239   (when (wl-e21-setup-toolbar wl-summary-toolbar)
 240     (wl-e21-make-toolbar-buttons wl-summary-mode-map wl-summary-toolbar)))
 241
 242 (eval-when-compile
 243   (defsubst wl-e21-setup-message-toolbar (keymap)
 244     (when (wl-e21-setup-toolbar wl-message-toolbar)
 245       (wl-e21-make-toolbar-buttons keymap wl-message-toolbar)))
 246
 247   (defsubst wl-e21-setup-draft-toolbar ()
 248     (when (wl-e21-setup-toolbar wl-draft-toolbar)
 249       (wl-e21-make-toolbar-buttons wl-draft-mode-map wl-draft-toolbar))))
 250
 251 (defvar wl-folder-toggle-icon-list
 252   '((wl-folder-opened-image       . wl-opened-group-folder-icon)
 253     (wl-folder-closed-image       . wl-closed-group-folder-icon)))
 254
 255 (eval-when-compile
 256   (defsubst wl-e21-highlight-folder-group-line (start end icon numbers)
 257     (when (wl-e21-display-image-p)
 258       (let (overlay)
 259         (let ((overlays (overlays-in start end)))
 260           (while (and (setq overlay (pop overlays))
 261                       (not (overlay-get overlay 'wl-e21-icon)))))
 262         (unless overlay
 263           (setq overlay (make-overlay start end))
 264           (overlay-put overlay 'wl-e21-icon t)
 265           (overlay-put overlay 'evaporate t))
 266         (let ((image (get icon 'image)))
 267           (unless image
 268             (let ((name (symbol-value
 269                          (cdr (assq icon wl-folder-toggle-icon-list))))
 270                   (load-path (cons wl-icon-dir load-path)))
 271               (when (setq image (find-image `((:type xpm :file ,name
 272                                                      :ascent center))))
 273                 (setq image (put icon 'image (propertize name
 274                                                          'display image))))))
 275           (overlay-put overlay 'before-string image)
 276           (overlay-put overlay 'invisible (and image t))
 277           (when (and wl-use-highlight-mouse-line (display-mouse-p))
 278             (let ((inhibit-read-only t))
 279               (put-text-property (if image
 280                                      (max (1- start) (line-beginning-position))
 281                                    start)
 282                                  (line-end-position)
 283                                  'mouse-face 'highlight)))))))
 284
 285   (defsubst wl-e21-highlight-folder-by-numbers (start end text-face numbers)
 286     (when (display-color-p)
 287       (let ((inhibit-read-only t))
 288         (if (and wl-highlight-folder-by-numbers
 289                  numbers (nth 0 numbers) (nth 1 numbers)
 290                  (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+"
 291                                     (line-end-position) t))
 292             (let* ((unsync (nth 0 numbers))
 293                    (unread (nth 1 numbers))
 294                    (face (cond ((and unsync (zerop unsync))
 295                                 (if (and unread (zerop unread))
 296                                     'wl-highlight-folder-zero-face
 297                                   'wl-highlight-folder-unread-face))
 298                                ((and unsync
 299                                      (>= unsync
 300                                          wl-folder-many-unsync-threshold))
 301                                 'wl-highlight-folder-many-face)
 302                                (t
 303                                 'wl-highlight-folder-few-face))))
 304               (if (numberp wl-highlight-folder-by-numbers)
 305                   (progn
 306                     (put-text-property start (match-beginning 0)
 307                                        'face text-face)
 308                     (put-text-property (match-beginning 0) (match-end 0)
 309                                        'face face))
 310                 (put-text-property start (match-end 0) 'face face)))
 311           (put-text-property start (line-end-position) 'face text-face))))))
 312
 313 (defun wl-highlight-folder-current-line (&optional numbers)
 314   (interactive)
 315   (save-excursion
 316     (beginning-of-line)
 317     (let (fld-name start end)
 318       (cond
 319        (;; opened folder group
 320         (looking-at wl-highlight-folder-opened-regexp)
 321         (setq start (match-beginning 1)
 322               end (match-end 1))
 323         (wl-e21-highlight-folder-group-line start end
 324                                             'wl-folder-opened-image
 325                                             numbers)
 326         (wl-e21-highlight-folder-by-numbers start end
 327                                             'wl-highlight-folder-opened-face
 328                                             numbers))
 329        (;; closed folder group
 330         (looking-at wl-highlight-folder-closed-regexp)
 331         (setq start (match-beginning 1)
 332               end (match-end 1))
 333         (wl-e21-highlight-folder-group-line start end
 334                                             'wl-folder-closed-image
 335                                             numbers)
 336         (wl-e21-highlight-folder-by-numbers start end
 337                                             'wl-highlight-folder-closed-face
 338                                             numbers))
 339        (;; basic folder
 340         (and (setq fld-name (wl-folder-get-folder-name-by-id
 341                              (get-text-property (point) 'wl-folder-entity-id)))
 342              (looking-at "[\t ]+\\([^\t\n ]+\\)"))
 343         (setq start (match-beginning 1)
 344               end (match-end 1))
 345         (let (image)
 346           (when (wl-e21-display-image-p)
 347             (let (overlay)
 348               (let ((overlays (overlays-in start end)))
 349                 (while (and (setq overlay (pop overlays))
 350                             (not (overlay-get overlay 'wl-e21-icon)))))
 351               (unless overlay
 352                 (setq overlay (make-overlay start end))
 353                 (overlay-put overlay 'wl-e21-icon t)
 354                 (overlay-put overlay 'evaporate t))
 355               (let (type)
 356                 (unless (get (caar wl-folder-internal-icon-list) 'image)
 357                   (wl-folder-init-icons))
 358                 (setq image
 359                       (cond ((string= fld-name wl-trash-folder);; trash folder
 360                              (let ((num (nth 2 numbers)));; number of messages
 361                                (get (if (or (not num) (zerop num))
 362                                         'wl-folder-trash-empty-image
 363                                       'wl-folder-trash-image)
 364                                     'image)))
 365                             ((string= fld-name wl-draft-folder);; draft folder
 366                              (get 'wl-folder-draft-image 'image))
 367                             ((string= fld-name wl-queue-folder);; queue folder
 368                              (get 'wl-folder-queue-image 'image))
 369                             (;; and one of many other folders
 370                              (setq type (elmo-folder-type fld-name))
 371                              (get (intern (format "wl-folder-%s-image" type))
 372                                   'image)))))
 373               (overlay-put overlay 'before-string image)))
 374           (when (and wl-use-highlight-mouse-line (display-mouse-p))
 375             (let ((inhibit-read-only t))
 376               (put-text-property (if image
 377                                      (max (1- start)
 378                                           (line-beginning-position))
 379                                    start)
 380                                  (line-end-position)
 381                                  'mouse-face 'highlight))))
 382         (when (display-color-p)
 383           (wl-e21-highlight-folder-by-numbers
 384            start end
 385            (if (looking-at (format "^[\t ]*\\(%s\\|%s\\)"
 386                                    wl-folder-unsubscribe-mark
 387                                    wl-folder-removed-mark))
 388                'wl-highlight-folder-killed-face
 389              'wl-highlight-folder-unknown-face)
 390            numbers)))))))
 391
 392 (defun wl-highlight-plugged-current-line ()
 393   (interactive)
 394   (when (wl-e21-display-image-p)
 395     (save-excursion
 396       (beginning-of-line)
 397       (when (looking-at "[\t ]*\\(\\[\\([^]]+\\)\\]\\)")
 398         (let* ((start (match-beginning 1))
 399                (end (match-end 1))
 400                (status (match-string-no-properties 2))
 401                (image (if (string-equal wl-plugged-plug-on status)
 402                           wl-plugged-image
 403                         wl-unplugged-image)))
 404           (when image
 405             (let (overlay)
 406               (let ((overlays (overlays-in start end)))
 407                 (while (and (setq overlay (pop overlays))
 408                             (not (overlay-get overlay 'wl-e21-icon)))))
 409               (unless overlay
 410                 (setq overlay (make-overlay start end))
 411                 (overlay-put overlay 'wl-e21-icon t)
 412                 (overlay-put overlay 'evaporate t))
 413               (put-text-property 0 (length status) 'display image status)
 414               (overlay-put overlay 'before-string status)
 415               (overlay-put overlay 'invisible t))))))))
 416
 417 (defun wl-plugged-set-folder-icon (folder string)
 418   (if (wl-e21-display-image-p)
 419       (let (type)
 420         (cond ((string= folder wl-queue-folder)
 421                (concat (get 'wl-folder-queue-image 'image)
 422                        string))
 423               ((setq type (elmo-folder-type folder))
 424                (concat (get (intern (format "wl-folder-%s-image"
 425                                             type))
 426                             'image)
 427                        string))
 428               (t
 429                string)))
 430     string))
 431
 432 (defvar wl-folder-internal-icon-list
 433   ;; alist of (image . icon-file)
 434   '((wl-folder-nntp-image         . wl-nntp-folder-icon)
 435     (wl-folder-imap4-image        . wl-imap-folder-icon)
 436     (wl-folder-pop3-image         . wl-pop-folder-icon)
 437     (wl-folder-localdir-image     . wl-localdir-folder-icon)
 438     (wl-folder-localnews-image    . wl-localnews-folder-icon)
 439     (wl-folder-internal-image     . wl-internal-folder-icon)
 440     (wl-folder-multi-image        . wl-multi-folder-icon)
 441     (wl-folder-filter-image       . wl-filter-folder-icon)
 442     (wl-folder-archive-image      . wl-archive-folder-icon)
 443     (wl-folder-pipe-image         . wl-pipe-folder-icon)
 444     (wl-folder-maildir-image      . wl-maildir-folder-icon)
 445     (wl-folder-nmz-image          . wl-nmz-folder-icon)
 446     (wl-folder-shimbun-image      . wl-shimbun-folder-icon)
 447     (wl-folder-trash-empty-image  . wl-empty-trash-folder-icon)
 448     (wl-folder-draft-image        . wl-draft-folder-icon)
 449     (wl-folder-queue-image        . wl-queue-folder-icon)
 450     (wl-folder-trash-image        . wl-trash-folder-icon)))
 451
 452 (defun wl-folder-init-icons ()
 453   (when (wl-e21-display-image-p)
 454     (let ((load-path (cons wl-icon-dir load-path))
 455           (icons wl-folder-internal-icon-list)
 456           icon name image)
 457       (while (setq icon (pop icons))
 458         (unless (get (car icon) 'image)
 459           (setq name (symbol-value (cdr icon))
 460                 image (find-image `((:type xpm :file ,name :ascent center))))
 461           (when image
 462             (put (car icon) 'image (propertize name 'display image))))))))
 463
 464 (defun wl-plugged-init-icons ()
 465   (let ((props (when (display-mouse-p)
 466                  (list 'local-map (purecopy (make-mode-line-mouse-map
 467                                              'mouse-2 #'wl-toggle-plugged))
 468                        'help-echo "mouse-2 toggles plugged status"))))
 469     (if (wl-e21-display-image-p)
 470         (progn
 471           (unless wl-plugged-image
 472             (let ((load-path (cons wl-icon-dir load-path)))
 473               (setq wl-plugged-image (find-image
 474                                       `((:type xpm
 475                                                :file ,wl-plugged-icon
 476                                                :ascent center)))
 477                     wl-unplugged-image (find-image
 478                                         `((:type xpm
 479                                                  :file ,wl-unplugged-icon
 480                                                  :ascent center))))))
 481           (setq wl-modeline-plug-state-on
 482                 (apply 'propertize wl-plug-state-indicator-on
 483                        `(display ,wl-plugged-image ,@props))
 484                 wl-modeline-plug-state-off
 485                 (apply 'propertize wl-plug-state-indicator-off
 486                        `(display ,wl-unplugged-image ,@props))))
 487       (if props
 488           (setq wl-modeline-plug-state-on
 489                 (apply 'propertize wl-plug-state-indicator-on props)
 490                 wl-modeline-plug-state-off
 491                 (apply 'propertize wl-plug-state-indicator-off props))
 492         (setq wl-modeline-plug-state-on wl-plug-state-indicator-on
 493               wl-modeline-plug-state-off wl-plug-state-indicator-off)))))
 494
 495 (defun wl-biff-init-icons ()
 496   (let ((props (when (display-mouse-p)
 497                  (list 'local-map (purecopy (make-mode-line-mouse-map
 498                                              'mouse-2 #'wl-biff-check-folders))
 499                        'help-echo "mouse-2 checks new mails"))))
 500     (if (wl-e21-display-image-p)
 501         (progn
 502           (unless wl-biff-mail-image
 503             (let ((load-path (cons wl-icon-dir load-path)))
 504               (setq wl-biff-mail-image (find-image
 505                                         `((:type xpm
 506                                                  :file ,wl-biff-mail-icon
 507                                                  :ascent center)))
 508                     wl-biff-nomail-image (find-image
 509                                           `((:type xpm
 510                                                    :file ,wl-biff-nomail-icon
 511                                                    :ascent center))))))
 512           (setq wl-modeline-biff-state-on
 513                 (apply 'propertize wl-biff-state-indicator-on
 514                        `(display ,wl-biff-mail-image ,@props))
 515                 wl-modeline-biff-state-off
 516                 (apply 'propertize wl-biff-state-indicator-off
 517                        `(display ,wl-biff-nomail-image ,@props))))
 518       (if props
 519           (setq wl-modeline-biff-state-on
 520                 (apply 'propertize wl-biff-state-indicator-on props)
 521                 wl-modeline-biff-state-off
 522                 (apply 'propertize wl-biff-state-indicator-off props))
 523         (setq wl-modeline-biff-state-on wl-biff-state-indicator-on
 524               wl-modeline-biff-state-off wl-biff-state-indicator-off)))))
 525
 526 (defun wl-make-date-string ()
 527   (let ((system-time-locale "C"))
 528     (format-time-string "%a, %d %b %Y %T %z")))
 529
 530 (defalias 'wl-setup-folder 'wl-e21-setup-folder-toolbar)
 531
 532 (defalias 'wl-setup-summary 'wl-e21-setup-summary-toolbar)
 533
 534 (defun wl-message-overload-functions ()
 535   (let ((keymap (current-local-map)))
 536     (when keymap
 537       (wl-e21-setup-message-toolbar keymap)
 538       (define-key keymap "l" 'wl-message-toggle-disp-summary)
 539       (define-key keymap [mouse-2] 'wl-message-refer-article-or-url)
 540       (define-key keymap [mouse-4] 'wl-message-wheel-down)
 541       (define-key keymap [mouse-5] 'wl-message-wheel-up)
 542       (define-key keymap [S-mouse-4] 'wl-message-wheel-down)
 543       (define-key keymap [S-mouse-5] 'wl-message-wheel-up)
 544       (set-keymap-parent wl-message-button-map keymap)
 545       (define-key wl-message-button-map
 546         [mouse-2] 'wl-message-button-dispatcher))))
 547
 548 (defun wl-message-wheel-up (event)
 549   (interactive "e")
 550   (if (string-match (regexp-quote wl-message-buffer-cache-name)
 551                     (regexp-quote (buffer-name)))
 552       (wl-message-next-page)
 553     (let ((cur-buf (current-buffer))
 554           proceed)
 555       (save-selected-window
 556         (select-window (posn-window (event-start event)))
 557         (set-buffer cur-buf)
 558         (setq proceed (wl-message-next-page)))
 559       (if proceed
 560           (if (memq 'shift (event-modifiers event))
 561               (wl-summary-down t)
 562             (wl-summary-next t))))))
 563
 564 (defun wl-message-wheel-down (event)
 565   (interactive "e")
 566   (if (string-match (regexp-quote wl-message-buffer-cache-name)
 567                     (regexp-quote (buffer-name)))
 568       (wl-message-prev-page)
 569     (let ((cur-buf (current-buffer))
 570           proceed)
 571       (save-selected-window
 572         (select-window (posn-window (event-start event)))
 573         (set-buffer cur-buf)
 574         (setq proceed (wl-message-prev-page)))
 575       (if proceed
 576           (if (memq 'shift (event-modifiers event))
 577               (wl-summary-up t)
 578             (wl-summary-prev t))))))
 579
 580 (defun wl-draft-overload-menubar ()
 581   (let ((keymap (current-local-map)))
 582     (define-key keymap [menu-bar mail send]
 583       '("Send Message" . wl-draft-send-and-exit))
 584     (define-key keymap [menu-bar mail send-stay]
 585       '("Send, Keep Editing" . wl-draft-send))
 586     (define-key keymap [menu-bar mail cancel]
 587       '("Kill Current Draft" . wl-draft-kill))
 588     (define-key keymap [menu-bar mail yank]
 589       '("Cite Message" . wl-draft-yank-original))
 590     (define-key keymap [menu-bar mail signature]
 591       '("Insert Signature" . insert-signature))
 592     (define-key keymap [menu-bar headers fcc]
 593       '("Fcc" . wl-draft-fcc))))
 594
 595 (defun wl-draft-mode-setup ()
 596   (require 'derived)
 597   (define-derived-mode wl-draft-mode mail-mode "Draft"
 598     "draft mode for Wanderlust derived from mail mode.
 599 See info under Wanderlust for full documentation.
 600
 601 Special commands:
 602 \\{wl-draft-mode-map}"))
 603
 604 (defun wl-draft-key-setup ()
 605   (define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
 606   (define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
 607   (define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
 608   (define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
 609   (define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
 610   (define-key wl-draft-mode-map "\C-l" 'wl-draft-highlight-and-recenter)
 611   (define-key wl-draft-mode-map "\C-i" 'wl-complete-field-body-or-tab)
 612   (define-key wl-draft-mode-map "\C-c\C-r" 'wl-draft-caesar-region)
 613   (define-key wl-draft-mode-map "\M-t" 'wl-toggle-plugged)
 614   (define-key wl-draft-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
 615   (define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
 616   (define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
 617   (define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
 618   (define-key wl-draft-mode-map "\C-c\C-a" 'wl-addrmgr)
 619   (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
 620   (define-key wl-draft-mode-map "\C-xk"    'wl-draft-mimic-kill-buffer))
 621
 622 (defun wl-draft-overload-functions ()
 623   (wl-mode-line-buffer-identification)
 624 ;;  (local-set-key "\C-c\C-s" 'wl-draft-send);; override
 625   (wl-e21-setup-draft-toolbar)
 626   (wl-draft-overload-menubar))
 627
 628 (defalias 'wl-defface 'defface)
 629
 630 (defun wl-read-event-char ()
 631   "Get the next event."
 632   (let ((event (read-event)))
 633     (cons (and (numberp event) event) event)))
 634
 635 (require 'product)
 636 (product-provide (provide 'wl-e21) (require 'wl-version))
 637
 638 ;;; wl-e21.el ends here