1
;;; wl-e21.el --- Wanderlust modules for Emacs 21.
3
;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>
4
;; Copyright (C) 2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
6
;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
7
;; Keywords: mail, net news
9
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
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)
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.
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.
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.
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-directory 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*"))
45
;; (setq from (point))
46
;; (insert "-fj.wanderlust:0/0/0")
49
;; (setq overlay (make-overlay from to))
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))
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.
71
(require 'wl-highlight)
72
(defvar-maybe wl-folder-mode-map (make-sparse-keymap))
73
(defvar-maybe wl-draft-mode-map (make-sparse-keymap)))
75
(add-hook 'wl-folder-mode-hook 'wl-setup-folder)
76
(add-hook 'wl-folder-mode-hook 'wl-folder-init-icons)
78
(add-hook 'wl-init-hook 'wl-biff-init-icons)
79
(add-hook 'wl-init-hook 'wl-plugged-init-icons)
81
(add-hook 'wl-summary-mode-hook 'wl-setup-summary)
83
(add-hook 'wl-message-display-internal-hook 'wl-setup-message)
85
(defvar wl-use-toolbar (image-type-available-p 'xpm))
86
(defvar wl-plugged-image nil)
87
(defvar wl-unplugged-image nil)
88
(defvar wl-biff-mail-image nil)
89
(defvar wl-biff-nomail-image nil)
91
(defvar wl-folder-toolbar
92
'([wl-folder-jump-to-current-entity
93
wl-folder-jump-to-current-entity t "Enter Current Folder"]
94
[wl-folder-next-entity
95
wl-folder-next-entity t "Next Folder"]
96
[wl-folder-prev-entity
97
wl-folder-prev-entity t "Previous Folder"]
98
[wl-folder-check-current-entity
99
wl-folder-check-current-entity t "Check Current Folder"]
101
;; wl-draft t "Write a New Message"]
102
[wl-folder-sync-current-entity
103
wl-folder-sync-current-entity t "Sync Current Folder"]
105
wl-draft t "Write a New Message"]
106
[wl-folder-empty-trash
107
wl-folder-empty-trash t "Empty Trash"]
109
wl-exit t "Quit Wanderlust"]
111
"The Folder buffer toolbar.")
113
(defvar wl-summary-toolbar
115
wl-summary-read t "Read Messages"]
117
wl-summary-next t "Next Message"]
119
wl-summary-prev t "Previous Message"]
120
[wl-summary-jump-to-current-message
121
wl-summary-jump-to-current-message t "Jump to Current Message"]
122
[wl-summary-sync-force-update
123
wl-summary-sync-force-update t "Sync Current Folder"]
125
wl-summary-delete t "Delete Current Message"]
126
[wl-summary-mark-as-important
127
wl-summary-mark-as-important t "Mark Current Message as Important"]
129
wl-draft t "Write a New Message"]
131
wl-summary-reply t "Reply to Current Message" ]
132
[wl-summary-reply-with-citation
133
wl-summary-reply-with-citation t "Reply to Current Message with Citation"]
135
wl-summary-forward t "Forward Current Message"]
137
wl-summary-exit t "Exit Current Summary"]
139
"The Summary buffer toolbar.")
141
(defvar wl-message-toolbar
143
wl-message-read t "Read Contents"]
144
[wl-message-next-content
145
wl-message-next-content t "Next Content"]
146
[wl-message-prev-content
147
wl-message-prev-content t "Previous Content"]
149
wl-message-quit t "Back to Summary"]
150
[wl-message-play-content
151
wl-message-play-content t "Play Content"]
152
[wl-message-extract-content
153
wl-message-extract-content t "Extract Content"]
155
"The Message buffer toolbar.")
157
(defalias 'wl-draft-insert-signature 'insert-signature);; for draft toolbar.
159
(defvar wl-draft-toolbar
160
'([wl-draft-send-from-toolbar
161
wl-draft-send-from-toolbar t "Send Current Draft"]
162
[wl-draft-yank-original
163
wl-draft-yank-original t "Yank Displaying Message"]
164
[wl-draft-insert-signature
165
wl-draft-insert-signature t "Insert Signature"]
167
wl-draft-kill t "Kill Current Draft"]
169
"The Draft buffer toolbar.")
172
(defmacro wl-e21-display-image-p ()
173
'(and (display-images-p)
174
(image-type-available-p 'xpm))))
176
(defun wl-e21-setup-toolbar (bar)
177
(when (and wl-use-toolbar
178
(wl-e21-display-image-p))
179
(let ((load-path (cons wl-icon-directory load-path))
180
(props '(:type xpm :ascent center
181
:color-symbols (("backgroundToolBarColor" . "None"))
184
icon up down disabled name)
186
(setq icon (aref (pop bar) 0))
187
(unless (boundp icon)
188
(setq name (symbol-name icon)
189
up (find-image `((,@props ,(concat name "-up.xpm")))))
192
(setq down (find-image `((,@props ,(concat name "-down.xpm"))))
194
`((,@props ,(concat name "-disabled.xpm")))))
195
(set icon (vector down up disabled disabled)))
200
(defvar wl-e21-toolbar-configurations
201
'((auto-resize-tool-bars . t)
202
(auto-raise-tool-bar-buttons . t)
203
(tool-bar-button-margin . 0)
204
(tool-bar-button-relief . 2)))
206
(defun wl-e21-make-toolbar-buttons (keymap defs)
207
(let ((configs wl-e21-toolbar-configurations)
209
(while (setq config (pop configs))
210
(set (make-local-variable (car config)) (cdr config))))
211
;; Invalidate the default bindings.
212
(let ((keys (cdr (key-binding [tool-bar] t)))
214
(while (setq item (pop keys))
215
(when (setq item (car-safe item))
216
(define-key keymap (vector 'tool-bar item) 'undefined))))
217
(let ((n (length defs))
222
(define-key keymap (vector 'tool-bar (aref def 1))
223
(list 'menu-item (aref def 3) (aref def 1)
225
:image (symbol-value (aref def 0)))))))
227
(defun wl-e21-setup-folder-toolbar ()
228
(when (wl-e21-setup-toolbar wl-folder-toolbar)
229
(wl-e21-make-toolbar-buttons wl-folder-mode-map wl-folder-toolbar)))
231
(defun wl-e21-setup-summary-toolbar ()
232
(when (wl-e21-setup-toolbar wl-summary-toolbar)
233
(wl-e21-make-toolbar-buttons wl-summary-mode-map wl-summary-toolbar)))
236
(defsubst wl-e21-setup-draft-toolbar ()
237
(when (wl-e21-setup-toolbar wl-draft-toolbar)
238
(wl-e21-make-toolbar-buttons wl-draft-mode-map wl-draft-toolbar))))
240
(defun wl-e21-setup-message-toolbar ()
241
(when (wl-e21-setup-toolbar wl-message-toolbar)
242
(wl-e21-make-toolbar-buttons (current-local-map) wl-message-toolbar)))
244
(defvar wl-folder-toggle-icon-list
245
'((wl-folder-opened-image . wl-opened-group-folder-icon)
246
(wl-folder-closed-image . wl-closed-group-folder-icon)))
249
(defsubst wl-e21-highlight-folder-group-line (start end icon numbers)
250
(when (wl-e21-display-image-p)
252
(let ((overlays (overlays-in start end)))
253
(while (and (setq overlay (pop overlays))
254
(not (overlay-get overlay 'wl-e21-icon)))))
256
(setq overlay (make-overlay start end))
257
(overlay-put overlay 'wl-e21-icon t)
258
(overlay-put overlay 'evaporate t))
259
(let ((image (get icon 'image)))
261
(let ((name (symbol-value
262
(cdr (assq icon wl-folder-toggle-icon-list))))
263
(load-path (cons wl-icon-directory load-path)))
264
(when (setq image (find-image `((:type xpm :file ,name
266
(setq image (put icon 'image (propertize name
268
(overlay-put overlay 'before-string image)
269
(overlay-put overlay 'invisible (and image t))
270
(when (and wl-use-highlight-mouse-line (display-mouse-p))
271
(let ((inhibit-read-only t))
272
(put-text-property (if image
273
(max (1- start) (line-beginning-position))
276
'mouse-face 'highlight)))))))
278
(defsubst wl-e21-highlight-folder-by-numbers (start end text-face numbers)
279
(when (display-color-p)
280
(let ((inhibit-read-only t))
281
(if (and wl-highlight-folder-by-numbers
282
numbers (nth 0 numbers) (nth 1 numbers)
283
(re-search-forward "[-[:digit:]]+/[-[:digit:]]+/[-[:digit:]]+"
284
(line-end-position) t))
285
(let* ((unsync (nth 0 numbers))
286
(unread (nth 1 numbers))
287
(face (cond ((and unsync (zerop unsync))
288
(if (and unread (zerop unread))
289
'wl-highlight-folder-zero-face
290
'wl-highlight-folder-unread-face))
293
wl-folder-many-unsync-threshold))
294
'wl-highlight-folder-many-face)
296
'wl-highlight-folder-few-face))))
297
(if (numberp wl-highlight-folder-by-numbers)
299
(put-text-property start (match-beginning 0)
301
(put-text-property (match-beginning 0) (match-end 0)
303
(put-text-property start (match-end 0) 'face face)))
304
(put-text-property start (line-end-position) 'face text-face))))))
306
(defun wl-highlight-folder-current-line (&optional numbers)
310
(let (fld-name start end)
312
(;; opened folder group
313
(looking-at wl-highlight-folder-opened-regexp)
314
(setq start (match-beginning 1)
316
(wl-e21-highlight-folder-group-line start end
317
'wl-folder-opened-image
319
(wl-e21-highlight-folder-by-numbers start end
320
'wl-highlight-folder-opened-face
322
(;; closed folder group
323
(looking-at wl-highlight-folder-closed-regexp)
324
(setq start (match-beginning 1)
326
(wl-e21-highlight-folder-group-line start end
327
'wl-folder-closed-image
329
(wl-e21-highlight-folder-by-numbers start end
330
'wl-highlight-folder-closed-face
333
(and (setq fld-name (wl-folder-get-folder-name-by-id
334
(get-text-property (point) 'wl-folder-entity-id)))
335
(looking-at "[[:blank:]]+\\([^[:blank:]\n]+\\)"))
336
(setq start (match-beginning 1)
339
(when (wl-e21-display-image-p)
341
(let ((overlays (overlays-in start end)))
342
(while (and (setq overlay (pop overlays))
343
(not (overlay-get overlay 'wl-e21-icon)))))
345
(setq overlay (make-overlay start end))
346
(overlay-put overlay 'wl-e21-icon t)
347
(overlay-put overlay 'evaporate t))
349
(unless (get (caar wl-folder-internal-icon-list) 'image)
350
(wl-folder-init-icons))
352
(cond ((string= fld-name wl-trash-folder);; trash folder
353
(let ((num (nth 2 numbers)));; number of messages
354
(get (if (or (not num) (zerop num))
355
'wl-folder-trash-empty-image
356
'wl-folder-trash-image)
358
((string= fld-name wl-draft-folder);; draft folder
359
(get 'wl-folder-draft-image 'image))
360
((string= fld-name wl-queue-folder);; queue folder
361
(get 'wl-folder-queue-image 'image))
362
(;; and one of many other folders
363
(setq type (elmo-folder-type fld-name))
364
(get (intern (format "wl-folder-%s-image" type))
366
(overlay-put overlay 'before-string image)))
367
(when (and wl-use-highlight-mouse-line (display-mouse-p))
368
(let ((inhibit-read-only t))
369
(put-text-property (if image
371
(line-beginning-position))
374
'mouse-face 'highlight))))
375
(when (display-color-p)
376
(wl-e21-highlight-folder-by-numbers
378
(if (looking-at (format "^[[:blank:]]*\\(?:%s\\|%s\\)"
379
wl-folder-unsubscribe-mark
380
wl-folder-removed-mark))
381
'wl-highlight-folder-killed-face
382
'wl-highlight-folder-unknown-face)
385
(defun wl-highlight-plugged-current-line ()
387
(when (wl-e21-display-image-p)
390
(when (looking-at "[[:blank:]]*\\(\\[\\([^]]+\\)\\]\\)")
391
(let* ((start (match-beginning 1))
393
(status (match-string-no-properties 2))
394
(image (if (string-equal wl-plugged-plug-on status)
396
wl-unplugged-image)))
399
(let ((overlays (overlays-in start end)))
400
(while (and (setq overlay (pop overlays))
401
(not (overlay-get overlay 'wl-e21-icon)))))
403
(setq overlay (make-overlay start end))
404
(overlay-put overlay 'wl-e21-icon t)
405
(overlay-put overlay 'evaporate t))
406
(put-text-property 0 (length status) 'display image status)
407
(overlay-put overlay 'before-string status)
408
(overlay-put overlay 'invisible t))))))))
410
(defun wl-plugged-set-folder-icon (folder string)
411
(if (wl-e21-display-image-p)
413
(cond ((string= folder wl-queue-folder)
414
(concat (get 'wl-folder-queue-image 'image)
416
((setq type (elmo-folder-type folder))
417
(concat (get (intern (format "wl-folder-%s-image"
425
(defvar wl-folder-internal-icon-list
426
;; alist of (image . icon-file)
427
'((wl-folder-nntp-image . wl-nntp-folder-icon)
428
(wl-folder-imap4-image . wl-imap-folder-icon)
429
(wl-folder-pop3-image . wl-pop-folder-icon)
430
(wl-folder-localdir-image . wl-localdir-folder-icon)
431
(wl-folder-localnews-image . wl-localnews-folder-icon)
432
(wl-folder-internal-image . wl-internal-folder-icon)
433
(wl-folder-multi-image . wl-multi-folder-icon)
434
(wl-folder-filter-image . wl-filter-folder-icon)
435
(wl-folder-archive-image . wl-archive-folder-icon)
436
(wl-folder-pipe-image . wl-pipe-folder-icon)
437
(wl-folder-maildir-image . wl-maildir-folder-icon)
438
(wl-folder-nmz-image . wl-nmz-folder-icon)
439
(wl-folder-shimbun-image . wl-shimbun-folder-icon)
440
(wl-folder-trash-empty-image . wl-empty-trash-folder-icon)
441
(wl-folder-draft-image . wl-draft-folder-icon)
442
(wl-folder-queue-image . wl-queue-folder-icon)
443
(wl-folder-trash-image . wl-trash-folder-icon)))
445
(defun wl-folder-init-icons ()
446
(when (wl-e21-display-image-p)
447
(let ((load-path (cons wl-icon-directory load-path))
448
(icons wl-folder-internal-icon-list)
450
(while (setq icon (pop icons))
451
(unless (get (car icon) 'image)
452
(setq name (symbol-value (cdr icon))
453
image (find-image `((:type xpm :file ,name :ascent center))))
455
(put (car icon) 'image (propertize name 'display image))))))))
457
(defun wl-plugged-init-icons ()
458
(let ((props (when (display-mouse-p)
459
(list 'local-map (purecopy (make-mode-line-mouse-map
460
'mouse-2 #'wl-toggle-plugged))
461
'help-echo "mouse-2 toggles plugged status"))))
462
(if (wl-e21-display-image-p)
464
(unless wl-plugged-image
465
(let ((load-path (cons wl-icon-directory load-path)))
466
(setq wl-plugged-image (find-image
468
:file ,wl-plugged-icon
470
wl-unplugged-image (find-image
472
:file ,wl-unplugged-icon
474
(setq wl-modeline-plug-state-on
475
(apply 'propertize wl-plug-state-indicator-on
476
`(display ,wl-plugged-image ,@props))
477
wl-modeline-plug-state-off
478
(apply 'propertize wl-plug-state-indicator-off
479
`(display ,wl-unplugged-image ,@props))))
481
(setq wl-modeline-plug-state-on
482
(apply 'propertize wl-plug-state-indicator-on props)
483
wl-modeline-plug-state-off
484
(apply 'propertize wl-plug-state-indicator-off props))
485
(setq wl-modeline-plug-state-on wl-plug-state-indicator-on
486
wl-modeline-plug-state-off wl-plug-state-indicator-off)))))
488
(defun wl-biff-init-icons ()
489
(let ((props (when (display-mouse-p)
490
(list 'local-map (purecopy (make-mode-line-mouse-map
491
'mouse-2 #'wl-biff-check-folders))
492
'help-echo "mouse-2 checks new mails"))))
493
(if (wl-e21-display-image-p)
495
(unless wl-biff-mail-image
496
(let ((load-path (cons wl-icon-directory load-path)))
497
(setq wl-biff-mail-image (find-image
499
:file ,wl-biff-mail-icon
501
wl-biff-nomail-image (find-image
503
:file ,wl-biff-nomail-icon
505
(setq wl-modeline-biff-state-on
506
(apply 'propertize wl-biff-state-indicator-on
507
`(display ,wl-biff-mail-image ,@props))
508
wl-modeline-biff-state-off
509
(apply 'propertize wl-biff-state-indicator-off
510
`(display ,wl-biff-nomail-image ,@props))))
512
(setq wl-modeline-biff-state-on
513
(apply 'propertize wl-biff-state-indicator-on props)
514
wl-modeline-biff-state-off
515
(apply 'propertize wl-biff-state-indicator-off props))
516
(setq wl-modeline-biff-state-on wl-biff-state-indicator-on
517
wl-modeline-biff-state-off wl-biff-state-indicator-off)))))
519
(defun wl-make-date-string ()
520
(let ((system-time-locale "C"))
521
(format-time-string "%a, %d %b %Y %T %z")))
523
(defalias 'wl-setup-folder 'wl-e21-setup-folder-toolbar)
525
(defalias 'wl-setup-summary 'wl-e21-setup-summary-toolbar)
527
(defun wl-message-define-keymap ()
528
(let ((keymap (make-sparse-keymap)))
529
(define-key keymap "l" 'wl-message-toggle-disp-summary)
530
(define-key keymap [mouse-4] 'wl-message-wheel-down)
531
(define-key keymap [mouse-5] 'wl-message-wheel-up)
532
(define-key keymap [S-mouse-4] 'wl-message-wheel-down)
533
(define-key keymap [S-mouse-5] 'wl-message-wheel-up)
534
(set-keymap-parent wl-message-button-map keymap)
535
(define-key wl-message-button-map
536
[mouse-2] 'wl-message-button-dispatcher)
539
(defalias 'wl-setup-message 'wl-e21-setup-message-toolbar)
541
(defun wl-message-wheel-up (event)
543
(if (string-match (regexp-quote wl-message-buffer-cache-name)
544
(regexp-quote (buffer-name)))
545
(wl-message-next-page)
546
(let ((cur-buf (current-buffer))
548
(save-selected-window
549
(select-window (posn-window (event-start event)))
551
(setq proceed (wl-message-next-page)))
553
(if (memq 'shift (event-modifiers event))
555
(wl-summary-next t))))))
557
(defun wl-message-wheel-down (event)
559
(if (string-match (regexp-quote wl-message-buffer-cache-name)
560
(regexp-quote (buffer-name)))
561
(wl-message-prev-page)
562
(let ((cur-buf (current-buffer))
564
(save-selected-window
565
(select-window (posn-window (event-start event)))
567
(setq proceed (wl-message-prev-page)))
569
(if (memq 'shift (event-modifiers event))
571
(wl-summary-prev t))))))
573
(defun wl-draft-overload-menubar ()
574
(let ((keymap (current-local-map)))
575
(define-key keymap [menu-bar mail send]
576
'("Send Message" . wl-draft-send-and-exit))
577
(define-key keymap [menu-bar mail send-stay]
578
'("Send, Keep Editing" . wl-draft-send))
579
(define-key keymap [menu-bar mail cancel]
580
'("Kill Current Draft" . wl-draft-kill))
581
(define-key keymap [menu-bar mail yank]
582
'("Cite Message" . wl-draft-yank-original))
583
(define-key keymap [menu-bar mail signature]
584
'("Insert Signature" . insert-signature))
585
(define-key keymap [menu-bar headers fcc]
586
'("Fcc" . wl-draft-fcc))))
588
(defun wl-draft-mode-setup ()
590
(define-derived-mode wl-draft-mode mail-mode "Draft"
591
"draft mode for Wanderlust derived from mail mode.
592
See info under Wanderlust for full documentation.
595
\\{wl-draft-mode-map}"))
597
(defun wl-draft-key-setup ()
598
(define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
599
(define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
600
(define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
601
(define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
602
(define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
603
(define-key wl-draft-mode-map "\C-l" 'wl-draft-highlight-and-recenter)
604
(define-key wl-draft-mode-map "\C-i" 'wl-complete-field-body-or-tab)
605
(define-key wl-draft-mode-map "\C-c\C-r" 'wl-draft-caesar-region)
606
(define-key wl-draft-mode-map "\M-t" 'wl-toggle-plugged)
607
(define-key wl-draft-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
608
(define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
609
(define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
610
(define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
611
(define-key wl-draft-mode-map "\C-c\C-a" 'wl-addrmgr)
612
(define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
613
(define-key wl-draft-mode-map "\C-xk" 'wl-draft-mimic-kill-buffer)
614
(define-key wl-draft-mode-map "\C-c\C-d" 'wl-draft-elide-region))
616
(defun wl-draft-overload-functions ()
617
(wl-mode-line-buffer-identification)
618
;; (local-set-key "\C-c\C-s" 'wl-draft-send);; override
619
(wl-e21-setup-draft-toolbar)
620
(wl-draft-overload-menubar))
622
(defalias 'wl-defface 'defface)
624
(defun wl-read-event-char ()
625
"Get the next event."
626
(let ((event (read-event)))
627
(cons (and (numberp event) event) event)))
630
(product-provide (provide 'wl-e21) (require 'wl-version))
632
;;; wl-e21.el ends here
added
removed
wl/wl-e21.el
