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