* wl-addrmgr.el (wl-addrmgr-quit-yes): Put cursor on draft buffer
[elisp/wanderlust.git] / wl / wl-xmas.el
1 ;;; wl-xmas.el --- Wanderlust modules for XEmacsen.
2
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 2000 Katsumi Yamaoka <yamaoka@jpl.org>
5
6 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
7 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
8 ;; Keywords: mail, net news
9
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
11
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16 ;;
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21 ;;
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26 ;;
27
28 ;;; Commentary:
29 ;;
30
31 ;;; Code:
32 ;;
33
34 (eval-when-compile
35   (require 'wl-folder)
36   (require 'wl-summary)
37   (require 'wl-draft)
38   (require 'wl-message)
39   (require 'wl-highlight)
40   (defvar-maybe wl-draft-mode-map (make-sparse-keymap))
41   (defalias-maybe 'toolbar-make-button-list 'ignore))
42
43 (add-hook 'wl-folder-mode-hook 'wl-setup-folder)
44 (add-hook 'wl-folder-mode-hook 'wl-folder-init-icons)
45
46 (add-hook 'wl-init-hook 'wl-biff-init-icons)
47 (add-hook 'wl-init-hook 'wl-plugged-init-icons)
48
49 (add-hook 'wl-summary-mode-hook 'wl-setup-summary)
50
51 (add-hook 'wl-message-display-internal-hook 'wl-setup-message)
52
53 (defvar wl-use-toolbar (if (featurep 'toolbar) 'default-toolbar nil))
54 (defvar wl-plugged-glyph nil)
55 (defvar wl-unplugged-glyph nil)
56 (defvar wl-biff-mail-glyph nil)
57 (defvar wl-biff-nomail-glyph nil)
58
59 (defvar wl-folder-toolbar
60   '([wl-folder-jump-to-current-entity
61      wl-folder-jump-to-current-entity t "Enter Current Folder"]
62     [wl-folder-next-entity
63      wl-folder-next-entity t "Next Folder"]
64     [wl-folder-prev-entity
65      wl-folder-prev-entity t "Previous Folder"]
66     [wl-folder-check-current-entity
67      wl-folder-check-current-entity t "Check Current Folder"]
68     [wl-folder-sync-current-entity
69      wl-folder-sync-current-entity t "Sync Current Folder"]
70     [wl-draft
71      wl-draft t "Write a New Message"]
72     [wl-write-current-folder
73      wl-folder-write-current-folder t "Write for Current Folder"]
74     [wl-folder-goto-draft-folder
75      wl-folder-goto-draft-folder t "Go to Draft Folder"]
76     [wl-folder-empty-trash
77      wl-folder-empty-trash t "Empty Trash"]
78     [wl-exit
79      wl-exit t "Quit Wanderlust"]
80     )
81   "The Folder buffer toolbar.")
82
83 (defvar wl-summary-toolbar
84   '([wl-summary-read
85      wl-summary-read t "Read Messages"]
86     [wl-summary-next
87      wl-summary-next t "Next Message"]
88     [wl-summary-prev
89      wl-summary-prev t "Previous Message"]
90     [wl-summary-jump-to-current-message
91      wl-summary-jump-to-current-message t "Jump to Current Message"]
92     [wl-summary-sync-force-update
93      wl-summary-sync-force-update t "Sync Current Folder"]
94     [wl-summary-delete
95      wl-summary-delete t "Delete Current Message"]
96     [wl-summary-mark-as-important
97      wl-summary-mark-as-important t "Mark Current Message as Important"]
98     [wl-draft
99      wl-draft t "Write a New Message"]
100     [wl-write-current-folder
101      wl-summary-write-current-folder t "Write for Current Folder"]
102     [wl-summary-reply
103      wl-summary-reply t "Reply to Current Message" ]
104     [wl-summary-reply-with-citation
105      wl-summary-reply-with-citation t "Reply to Current Message with Citation"]
106     [wl-summary-forward
107      wl-summary-forward t "Forward Current Message"]
108     [wl-summary-exit
109      wl-summary-exit t "Exit Current Summary"]
110     )
111   "The Summary buffer toolbar.")
112
113 (defvar wl-message-toolbar
114   '([wl-message-read
115      wl-message-read t "Read Contents"]
116     [wl-message-next-content
117      wl-message-next-content t "Next Content"]
118     [wl-message-prev-content
119      wl-message-prev-content t "Previous Content"]
120     [wl-message-quit
121      wl-message-quit t "Back to Summary"]
122     [wl-message-play-content
123      wl-message-play-content t "Play Content"]
124     [wl-message-extract-content
125      wl-message-extract-content t "Extract Content"]
126     )
127   "The Message buffer toolbar.")
128
129 (defalias 'wl-draft-insert-signature 'insert-signature);; for draft toolbar.
130
131 (defvar wl-draft-toolbar
132   '([wl-draft-send-from-toolbar
133      wl-draft-send-from-toolbar t "Send Current Draft"]
134     [wl-draft-yank-original
135      wl-draft-yank-original t "Yank Displaying Message"]
136     [wl-draft-insert-signature
137      wl-draft-insert-signature t "Insert Signature"]
138     [wl-draft-kill
139      wl-draft-kill t "Kill Current Draft"]
140     [wl-draft-save-and-exit
141      wl-draft-save-and-exit t "Save Draft and Exit"]
142     )
143   "The Draft buffer toolbar.")
144
145 (defun wl-xmas-setup-toolbar (bar)
146   (let ((dir wl-icon-directory)
147         icon up down disabled name)
148     (when dir
149       (while bar
150         (setq icon (aref (car bar) 0)
151               name (symbol-name icon)
152               bar (cdr bar))
153         (unless (boundp icon)
154           (setq up (expand-file-name (concat name "-up.xpm") dir)
155                 down (expand-file-name (concat name "-down.xpm") dir)
156                 disabled (expand-file-name (concat name "-disabled.xpm") dir))
157           (if (file-exists-p up)
158               (set icon (toolbar-make-button-list
159                          up (and (file-exists-p down) down)
160                          (and (file-exists-p disabled) disabled)))
161             (setq bar nil
162                   dir nil)))))
163     dir))
164
165 (defun wl-xmas-make-icon-glyph (icon-string icon-file
166                                             &optional locale tag-set)
167   (let ((glyph (make-glyph (vector 'string :data icon-string))))
168     (when wl-highlight-folder-with-icon
169       (set-glyph-image glyph
170                        (vector 'xpm :file (expand-file-name
171                                            icon-file wl-icon-directory))
172                        locale tag-set 'prepend))
173     glyph))
174
175 (eval-when-compile
176   (defsubst wl-xmas-setup-folder-toolbar ()
177     (and wl-use-toolbar
178          (wl-xmas-setup-toolbar wl-folder-toolbar)
179          (set-specifier (symbol-value wl-use-toolbar)
180                         (cons (current-buffer) wl-folder-toolbar))))
181
182   (defsubst wl-xmas-setup-summary-toolbar ()
183     (and wl-use-toolbar
184          (wl-xmas-setup-toolbar wl-summary-toolbar)
185          (set-specifier (symbol-value wl-use-toolbar)
186                         (cons (current-buffer) wl-summary-toolbar))))
187
188   (defsubst wl-xmas-setup-draft-toolbar ()
189     (and wl-use-toolbar
190          (wl-xmas-setup-toolbar wl-draft-toolbar)
191          (set-specifier (symbol-value wl-use-toolbar)
192                         (cons (current-buffer) wl-draft-toolbar)))))
193
194 (defun wl-xmas-setup-message-toolbar ()
195   (and wl-use-toolbar
196        (wl-xmas-setup-toolbar wl-message-toolbar)
197        (set-specifier (symbol-value wl-use-toolbar)
198                       (cons (current-buffer) wl-message-toolbar))))
199
200 (defvar wl-folder-toggle-icon-list
201   '((wl-folder-opened-glyph       . wl-opened-group-folder-icon)
202     (wl-folder-closed-glyph       . wl-closed-group-folder-icon)))
203
204 (eval-when-compile
205   (defsubst wl-xmas-highlight-folder-group-line (glyph text-face numbers)
206     (let ((start (match-beginning 1))
207           (end (match-end 1)))
208       (let (extent)
209         (while (and (setq extent (extent-at start nil nil extent 'at))
210                     (not (and (eq start (extent-start-position extent))
211                               (eq end (extent-end-position extent))
212                               (extent-end-glyph extent)))))
213         (unless extent
214           (setq extent (make-extent start end)))
215         (set-extent-properties extent `(end-open t start-closed t invisible t))
216         (set-extent-end-glyph
217          extent
218          (or (get glyph 'glyph)
219              (put glyph 'glyph
220                   (wl-xmas-make-icon-glyph
221                    (buffer-substring-no-properties start end)
222                    (symbol-value
223                     (cdr (assq glyph wl-folder-toggle-icon-list))))))))
224       (let ((inhibit-read-only t))
225         (when wl-use-highlight-mouse-line
226           (put-text-property start (point-at-eol) 'mouse-face 'highlight))
227         (setq start end
228               end (point-at-eol))
229         (if (and wl-highlight-folder-by-numbers
230                  numbers (nth 0 numbers) (nth 1 numbers)
231                  (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" end t))
232             (let* ((unsync (nth 0 numbers))
233                    (unread (nth 1 numbers))
234                    (face (cond ((and unsync (zerop unsync))
235                                 (if (and unread (zerop unread))
236                                     'wl-highlight-folder-zero-face
237                                   'wl-highlight-folder-unread-face))
238                                ((and unsync
239                                      (>= unsync
240                                          wl-folder-many-unsync-threshold))
241                                 'wl-highlight-folder-many-face)
242                                (t
243                                 'wl-highlight-folder-few-face))))
244               (if (numberp wl-highlight-folder-by-numbers)
245                   (progn
246                     (put-text-property start (match-beginning 0)
247                                        'face text-face)
248                     (put-text-property (match-beginning 0) (point) 'face face))
249                 (put-text-property start end 'face face)))
250           (put-text-property start end 'face text-face))))))
251
252 (defun wl-highlight-folder-current-line (&optional numbers)
253   (interactive)
254   (save-excursion
255     (beginning-of-line)
256     (let (fld-name)
257       (cond
258        (;; opened folder group
259         (looking-at wl-highlight-folder-opened-regexp)
260         (wl-xmas-highlight-folder-group-line 'wl-folder-opened-glyph
261                                              'wl-highlight-folder-opened-face
262                                              numbers))
263        (;; closed folder group
264         (looking-at wl-highlight-folder-closed-regexp)
265         (wl-xmas-highlight-folder-group-line 'wl-folder-closed-glyph
266                                              'wl-highlight-folder-closed-face
267                                              numbers))
268        (;; basic folder
269         (and (setq fld-name (wl-folder-get-folder-name-by-id
270                              (get-text-property (point) 'wl-folder-entity-id)))
271              (looking-at "[ \t]+\\([^ \t]+\\)"))
272         (let ((start (match-beginning 1)))
273           (let (extent)
274             (while (and (setq extent (extent-at start nil nil extent 'at))
275                         (not (and (eq start (extent-start-position extent))
276                                   (eq start (extent-end-position extent))
277                                   (extent-begin-glyph extent)))))
278             (unless extent
279               (setq extent (make-extent start start)))
280             (let (type)
281               (set-extent-begin-glyph
282                extent
283                (cond
284                 ((string= fld-name wl-trash-folder);; trash folder
285                  (let ((num (nth 2 numbers)));; number of messages
286                    (get (if (or (not num) (zerop num))
287                             'wl-folder-trash-empty-glyph
288                           'wl-folder-trash-glyph)
289                         'glyph)))
290                 ((string= fld-name wl-draft-folder);; draft folder
291                  (get 'wl-folder-draft-glyph 'glyph))
292                 ((string= fld-name wl-queue-folder);; queue folder
293                  (get 'wl-folder-queue-glyph 'glyph))
294                 (;; and one of many other folders
295                  (setq type (elmo-folder-type fld-name))
296                  (get (intern (format "wl-folder-%s-glyph" type)) 'glyph))))))
297           (let ((end (point-at-eol)))
298             (when wl-use-highlight-mouse-line
299               (put-text-property start end 'mouse-face 'highlight))
300             (let ((text-face
301                    (if (looking-at (format "^[ \t]*\\(?:%s\\|%s\\)"
302                                            wl-folder-unsubscribe-mark
303                                            wl-folder-removed-mark))
304                        'wl-highlight-folder-killed-face
305                      'wl-highlight-folder-unknown-face)))
306               (if (and wl-highlight-folder-by-numbers
307                        numbers (nth 0 numbers) (nth 1 numbers)
308                        (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" end t))
309                   (let* ((unsync (nth 0 numbers))
310                          (unread (nth 1 numbers))
311                          (face (cond
312                                 ((and unsync (zerop unsync))
313                                  (if (and unread (zerop unread))
314                                      'wl-highlight-folder-zero-face
315                                    'wl-highlight-folder-unread-face))
316                                 ((and unsync
317                                       (>= unsync
318                                           wl-folder-many-unsync-threshold))
319                                  'wl-highlight-folder-many-face)
320                                 (t
321                                  'wl-highlight-folder-few-face))))
322                     (if (numberp wl-highlight-folder-by-numbers)
323                         (progn
324                           (put-text-property start (match-beginning 0)
325                                              'face text-face)
326                           (put-text-property (match-beginning 0)
327                                              (match-end 0)
328                                              'face face))
329                       ;; Remove previous face.
330                       (put-text-property start (match-end 0) 'face nil)
331                       (put-text-property start (match-end 0) 'face face)))
332                 (put-text-property start end 'face text-face))))))))))
333
334 (defun wl-highlight-plugged-current-line ()
335   (interactive)
336   (save-excursion
337     (let ((inhibit-read-only t)
338           extent switch)
339       (beginning-of-line)
340       (when (looking-at "[ \t]*\\(\\[\\([^]]+\\)\\]\\)")
341         (setq switch (elmo-match-buffer 2))
342         (when (and (setq extent (extent-at (match-end 1) nil nil nil 'at))
343                    (extent-end-glyph extent))
344           (delete-extent extent))
345         (setq extent (make-extent (match-beginning 1) (match-end 1)))
346         (set-extent-property extent 'end-open t)
347         (set-extent-property extent 'start-closed t)
348         (set-extent-property extent 'invisible t)
349         (set-extent-end-glyph extent (if (string= switch wl-plugged-plug-on)
350                                          wl-plugged-glyph
351                                        wl-unplugged-glyph))))))
352
353 (defun wl-plugged-set-folder-icon (folder string)
354   (let ((string (copy-sequence string))
355         (len (length string))
356         type)
357     (if (string= folder wl-queue-folder)
358         (put-text-property 0 len 'begin-glyph
359                            (get 'wl-folder-queue-glyph 'glyph)
360                            string)
361       (if (setq type (elmo-folder-type folder))
362           (put-text-property 0 len
363                              'begin-glyph
364                              (get (intern (format "wl-folder-%s-glyph" type))
365                                   'glyph)
366                              string)))
367     string))
368
369 (defvar wl-folder-internal-icon-list
370   ;; alist of (glyph . icon-file)
371   '((wl-folder-nntp-glyph       . wl-nntp-folder-icon)
372     (wl-folder-imap4-glyph      . wl-imap-folder-icon)
373     (wl-folder-pop3-glyph       . wl-pop-folder-icon)
374     (wl-folder-localdir-glyph   . wl-localdir-folder-icon)
375     (wl-folder-localnews-glyph  . wl-localnews-folder-icon)
376     (wl-folder-internal-glyph   . wl-internal-folder-icon)
377     (wl-folder-multi-glyph      . wl-multi-folder-icon)
378     (wl-folder-filter-glyph     . wl-filter-folder-icon)
379     (wl-folder-archive-glyph    . wl-archive-folder-icon)
380     (wl-folder-pipe-glyph       . wl-pipe-folder-icon)
381     (wl-folder-maildir-glyph    . wl-maildir-folder-icon)
382     (wl-folder-nmz-glyph        . wl-nmz-folder-icon)
383     (wl-folder-shimbun-glyph    . wl-shimbun-folder-icon)
384     (wl-folder-trash-empty-glyph . wl-empty-trash-folder-icon)
385     (wl-folder-draft-glyph      . wl-draft-folder-icon)
386     (wl-folder-queue-glyph      . wl-queue-folder-icon)
387     (wl-folder-trash-glyph      . wl-trash-folder-icon)))
388
389 (defun wl-folder-init-icons ()
390   (dolist (icon wl-folder-internal-icon-list)
391     (unless (get (car icon) 'glyph)
392       (put (car icon) 'glyph
393            (wl-xmas-make-icon-glyph "" (symbol-value (cdr icon)))))))
394
395 (defun wl-plugged-init-icons ()
396   (unless wl-plugged-glyph
397     (setq wl-plugged-glyph (wl-xmas-make-icon-glyph
398                             wl-plug-state-indicator-on wl-plugged-icon)
399           wl-unplugged-glyph (wl-xmas-make-icon-glyph
400                               wl-plug-state-indicator-off wl-unplugged-icon))
401     (let ((extent (make-extent nil nil)))
402       (let ((keymap (make-sparse-keymap)))
403         (define-key keymap 'button2
404           (make-modeline-command-wrapper 'wl-toggle-plugged))
405         (set-extent-keymap extent keymap)
406         (set-extent-property extent 'help-echo
407                              "button2 toggles plugged status"))
408       (setq wl-modeline-plug-state-on (cons extent wl-plugged-glyph)
409             wl-modeline-plug-state-off (cons extent wl-unplugged-glyph)))))
410
411 (defun wl-biff-init-icons ()
412   (unless wl-biff-mail-glyph
413     (setq wl-biff-mail-glyph (wl-xmas-make-icon-glyph
414                               wl-biff-state-indicator-on
415                               wl-biff-mail-icon)
416           wl-biff-nomail-glyph (wl-xmas-make-icon-glyph
417                                 wl-biff-state-indicator-off
418                                 wl-biff-nomail-icon))
419     (let ((extent (make-extent nil nil)))
420       (let ((keymap (make-sparse-keymap)))
421         (define-key keymap 'button2
422           (make-modeline-command-wrapper 'wl-biff-check-folders))
423         (set-extent-keymap extent keymap)
424         (set-extent-property extent 'help-echo "button2 checks new mails"))
425       (setq wl-modeline-biff-state-on (cons extent wl-biff-mail-glyph)
426             wl-modeline-biff-state-off (cons extent wl-biff-nomail-glyph)))))
427
428 (defun wl-make-date-string ()
429   (let ((s (current-time-string)))
430     (string-match "\\`\\([A-Z][a-z][a-z]\\) +[A-Z][a-z][a-z] +[0-9][0-9]? *[0-9][0-9]?:[0-9][0-9]:[0-9][0-9] *[0-9]?[0-9]?[0-9][0-9]"
431                   s)
432     (concat (wl-match-string 1 s) ", "
433             (timezone-make-date-arpa-standard s (current-time-zone)))))
434
435 (defun wl-setup-folder ()
436   (and (featurep 'scrollbar)
437        (set-specifier scrollbar-height (cons (current-buffer) 0)))
438   (wl-xmas-setup-folder-toolbar))
439
440 (defvar dragdrop-drop-functions)
441
442 (defun wl-setup-summary ()
443   (make-local-variable 'dragdrop-drop-functions)
444   (setq dragdrop-drop-functions '((wl-dnd-default-drop-message t t)))
445   (and (featurep 'scrollbar)
446        (set-specifier scrollbar-height (cons (current-buffer) 0)))
447   (wl-xmas-setup-summary-toolbar))
448
449 (defalias 'wl-setup-message 'wl-xmas-setup-message-toolbar)
450
451 (defun wl-message-define-keymap ()
452   (let ((keymap (make-sparse-keymap)))
453     (define-key keymap "l" 'wl-message-toggle-disp-summary)
454     (define-key keymap 'button4 'wl-message-wheel-down)
455     (define-key keymap 'button5 'wl-message-wheel-up)
456     (define-key keymap [(shift button4)] 'wl-message-wheel-down)
457     (define-key keymap [(shift button5)] 'wl-message-wheel-up)
458     (set-keymap-parent wl-message-button-map keymap)
459     (define-key wl-message-button-map 'button2
460       'wl-message-button-dispatcher)
461     keymap))
462
463 (defun wl-message-wheel-up (event)
464   (interactive "e")
465   (let ((cur-buf (current-buffer))
466         proceed)
467     (save-selected-window
468       (select-window (event-window event))
469       (set-buffer cur-buf)
470       (setq proceed (wl-message-next-page)))
471     (when proceed
472       (if (memq 'shift (event-modifiers event))
473           (wl-summary-down t)
474         (wl-summary-next t)))))
475
476 (defun wl-message-wheel-down (event)
477   (interactive "e")
478   (let ((cur-buf (current-buffer))
479         proceed)
480     (save-selected-window
481       (select-window (event-window event))
482       (set-buffer cur-buf)
483       (setq proceed (wl-message-prev-page)))
484     (when proceed
485       (if (memq 'shift (event-modifiers event))
486           (wl-summary-up t)
487         (wl-summary-prev t)))))
488
489 (defun wl-draft-overload-menubar ()
490   (when (featurep 'menubar)
491 ;    (add-menu-item '("Mail") "Preview Message"
492 ;                  'wl-draft-preview-message t "Preview Message")
493     (add-menu-item '("Mail") "Send, Keep Editing"
494                    'wl-draft-send t "Send Mail")
495     (add-menu-item '("Mail") "Send Message"
496                    'wl-draft-send-and-exit t "Send and Exit")
497 ;    (add-menu-item '("Mail") "Save Draft and Exit"
498 ;                  'wl-draft-save-and-exit t "Save Draft and Exit")
499     (delete-menu-item '("Mail" "Send Mail"))
500     (delete-menu-item '("Mail" "Send and Exit"))))
501
502 (defun wl-draft-mode-setup ()
503   (require 'derived)
504   (define-derived-mode wl-draft-mode mail-mode "Draft"
505     "draft mode for Wanderlust derived from mail mode.
506 See info under Wanderlust for full documentation.
507
508 Special commands:
509 \\{wl-draft-mode-map}"))
510
511 (defun wl-draft-key-setup ()
512   (define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
513   (define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
514   (define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
515   (define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
516   (define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
517   (define-key wl-draft-mode-map "\C-l" 'wl-draft-highlight-and-recenter)
518   (define-key wl-draft-mode-map "\C-i" 'wl-complete-field-body-or-tab)
519   (define-key wl-draft-mode-map "\C-c\C-r" 'wl-draft-caesar-region)
520   (define-key wl-draft-mode-map "\M-t" 'wl-toggle-plugged)
521   (define-key wl-draft-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
522   (define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
523   (define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
524   (define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
525 ;;   (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
526   (define-key wl-draft-mode-map "\C-c\C-a" 'wl-addrmgr)
527   (define-key wl-draft-mode-map "\C-xk"    'wl-draft-mimic-kill-buffer)
528   (define-key wl-draft-mode-map "\C-c\C-d" 'wl-draft-elide-region))
529
530 (defun wl-draft-overload-functions ()
531   (wl-mode-line-buffer-identification)
532   ;; (local-set-key "\C-c\C-s" 'wl-draft-send);; override
533   (wl-xmas-setup-draft-toolbar)
534   (wl-draft-overload-menubar))
535
536 (defalias 'wl-defface 'defface)
537
538 (defun wl-read-event-char ()
539   "Get the next event."
540   (let ((event (next-command-event)))
541     (sit-for 0)
542     ;; We junk all non-key events.  Is this naughty?
543     (while (not (or (key-press-event-p event)
544                     (button-press-event-p event)))
545       (dispatch-event event)
546       (setq event (next-command-event)))
547     (cons (and (key-press-event-p event)
548                (event-to-character event))
549           event)))
550
551 (require 'product)
552 (product-provide (provide 'wl-xmas) (require 'wl-version))
553
554 ;;; wl-xmas.el ends here