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