1 ;;; wl-xmas.el -- Wanderlust modules for XEmacsen.
3 ;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
37 (require 'wl-highlight)
38 (defvar-maybe wl-draft-mode-map (make-sparse-keymap)))
40 (defun wl-xmas-setup-toolbar (bar)
41 (let ((dir wl-icon-dir)
42 icon up down disabled name)
45 (setq icon (aref (car bar) 0)
46 name (symbol-name icon)
48 (when (not (boundp icon))
49 (setq up (concat dir elmo-path-sep name "-up.xpm"))
50 (setq down (concat dir elmo-path-sep name "-down.xpm"))
51 (setq disabled (concat dir elmo-path-sep name "-disabled.xpm"))
52 (if (not (file-exists-p up))
55 (set icon (toolbar-make-button-list
56 up (and (file-exists-p down) down)
57 (and (file-exists-p disabled) disabled)))))))
60 (defvar wl-use-toolbar (if (featurep 'toolbar) 'default-toolbar nil))
61 (defvar wl-plugged-glyph nil)
62 (defvar wl-unplugged-glyph nil)
64 (defvar wl-folder-toolbar
65 '([wl-folder-jump-to-current-entity
66 wl-folder-jump-to-current-entity t "Enter Current Folder"]
67 [wl-folder-next-entity
68 wl-folder-next-entity t "Next Folder"]
69 [wl-folder-prev-entity
70 wl-folder-prev-entity t "Previous Folder"]
71 [wl-folder-check-current-entity
72 wl-folder-check-current-entity t "Check Current Folder"]
74 ; wl-draft t "Write a New Message"]
75 [wl-folder-sync-current-entity
76 wl-folder-sync-current-entity t "Sync Current Folder"]
78 wl-draft t "Write a New Message"]
79 [wl-folder-empty-trash
80 wl-folder-empty-trash t "Empty Trash"]
82 wl-exit t "Quit Wanderlust"]
84 "The Folder buffer toolbar.")
86 (defvar wl-summary-toolbar
88 wl-summary-read t "Read Messages"]
90 wl-summary-next t "Next Message"]
92 wl-summary-prev t "Previous Message"]
93 [wl-summary-jump-to-current-message
94 wl-summary-jump-to-current-message t "Jump to Current Message"]
95 [wl-summary-sync-force-update
96 wl-summary-sync-force-update t "Sync Current Folder"]
98 wl-summary-delete t "Delete Current Message"]
99 [wl-summary-mark-as-important
100 wl-summary-mark-as-important t "Mark Current Message as Important"]
102 wl-draft t "Write a New Message"]
104 wl-summary-reply t "Reply to Current Message" ]
105 [wl-summary-reply-with-citation
106 wl-summary-reply-with-citation t "Reply to Current Message with Citation"]
108 wl-summary-forward t "Forward Current Message"]
110 wl-summary-exit t "Exit Current Summary"]
112 "The Summary buffer toolbar.")
114 (defvar wl-message-toolbar
116 wl-message-read t "Read Contents"]
117 [wl-message-next-content
118 wl-message-next-content t "Next Content"]
119 [wl-message-prev-content
120 wl-message-prev-content t "Previous Content"]
122 wl-message-quit t "Back to Summary"]
123 [wl-message-play-content
124 wl-message-play-content t "Play Content"]
125 [wl-message-extract-content
126 wl-message-extract-content t "Extract Content"]
128 "The Message buffer toolbar.")
130 (defalias 'wl-draft-insert-signature 'insert-signature) ;; for draft toolbar.
132 (defvar wl-draft-toolbar
133 '([wl-draft-send-from-toolbar
134 wl-draft-send-from-toolbar t "Send Current Draft"]
135 [wl-draft-yank-original
136 wl-draft-yank-original t "Yank Displaying Message"]
137 [wl-draft-insert-signature
138 wl-draft-insert-signature t "Insert Signature"]
140 wl-draft-kill t "Kill Current Draft"]
142 "The Draft buffer toolbar.")
144 (defun wl-xmas-setup-folder-toolbar ()
146 (wl-xmas-setup-toolbar wl-folder-toolbar)
147 (set-specifier (symbol-value wl-use-toolbar)
148 (cons (current-buffer) wl-folder-toolbar))))
150 (defun wl-xmas-setup-summary-toolbar ()
152 (wl-xmas-setup-toolbar wl-summary-toolbar)
153 (set-specifier (symbol-value wl-use-toolbar)
154 (cons (current-buffer) wl-summary-toolbar))))
156 (defun wl-xmas-setup-message-toolbar ()
158 (wl-xmas-setup-toolbar wl-message-toolbar)
159 (set-specifier (symbol-value wl-use-toolbar)
160 (cons (current-buffer) wl-message-toolbar))))
162 (defun wl-xmas-setup-draft-toolbar ()
164 (wl-xmas-setup-toolbar wl-draft-toolbar)
165 (set-specifier (symbol-value wl-use-toolbar)
166 (cons (current-buffer) wl-draft-toolbar))))
168 ;; XEmacs implementations.
169 (defun wl-highlight-folder-current-line (&optional numbers)
172 (let ((highlights (list "opened" "closed"))
173 (inhibit-read-only t)
174 (fld-name (wl-folder-get-folder-name-by-id
175 (get-text-property (point) 'wl-folder-entity-id)))
176 fregexp fsymbol bol eol matched type extent num type glyph)
177 (setq eol (progn (end-of-line) (point))
178 bol (progn (beginning-of-line) (point)))
179 (when (and fld-name (looking-at "[ \t]+\\([^ \t]+\\)"))
180 (if (and (setq extent (extent-at (match-beginning 1) nil nil nil 'at))
181 (extent-begin-glyph extent))
182 (delete-extent extent))
183 (setq extent (make-extent (match-beginning 1) (match-beginning 1)))
185 ((string= fld-name wl-trash-folder) ;; set trash folder icon
186 (setq num (nth 2 numbers)) ;; number of messages
187 (set-extent-begin-glyph extent
190 wl-folder-trash-empty-glyph
191 wl-folder-trash-glyph)))
192 ((string= fld-name wl-draft-folder) ;; set draft folder icon
193 (set-extent-begin-glyph extent wl-folder-draft-glyph))
194 ((string= fld-name wl-queue-folder)
195 (set-extent-begin-glyph extent wl-folder-queue-glyph))
196 ((and (setq type (elmo-folder-get-type fld-name))
197 (or numbers ;; XXX dirty...!!
198 (not (assoc fld-name wl-folder-group-alist))))
200 (set-extent-begin-glyph extent
202 (intern (format "wl-folder-%s-glyph"
204 (when (and numbers (nth 0 numbers) (nth 1 numbers))
206 (let ((unsync (nth 0 numbers))
207 (unread (nth 1 numbers)))
208 (cond ((and unsync (eq unsync 0))
209 (if (and unread (> unread 0))
210 'wl-highlight-folder-unread-face
211 'wl-highlight-folder-zero-face))
213 (>= unsync wl-folder-many-unsync-threshold))
214 'wl-highlight-folder-many-face)
216 'wl-highlight-folder-few-face))))
217 (put-text-property bol eol 'face nil)
218 (put-text-property bol eol 'face fsymbol)
221 (setq fregexp (symbol-value
222 (intern (format "wl-highlight-folder-%s-regexp"
224 (if (not wl-highlight-group-folder-by-numbers)
225 (setq fsymbol (intern (format "wl-highlight-folder-%s-face"
227 (when (looking-at fregexp)
228 (setq extent (make-extent (match-beginning 1) (match-end 1))
229 glyph (intern (format "wl-folder-%s-glyph"
231 (if (null (symbol-value glyph))
232 (set glyph (wl-xmas-make-icon-glyph
233 (extent-string extent)
235 (cdr (assq glyph wl-folder-toggle-icon-list))))))
236 (setq glyph (symbol-value glyph))
237 (set-extent-property extent 'end-open t)
238 (set-extent-property extent 'start-closed t)
239 (set-extent-property extent 'invisible t)
240 (set-extent-end-glyph extent glyph)
241 (put-text-property bol eol 'face nil)
242 (put-text-property bol eol 'face fsymbol)
243 (setq matched t highlights nil))
244 (setq highlights (cdr highlights)))
246 (put-text-property bol eol 'face nil)
247 (if (looking-at (format "^[ ]*\\(%s\\|%s\\)"
248 wl-folder-unsubscribe-mark
249 wl-folder-removed-mark))
250 (put-text-property bol eol 'face
251 'wl-highlight-folder-killed-face)
252 (put-text-property bol eol 'face
253 'wl-highlight-folder-unknown-face)))
254 (if wl-use-highlight-mouse-line
255 (wl-highlight-folder-mouse-line))
256 (if (and (featurep 'dragdrop) wl-use-dnd)
257 (wl-dnd-set-drop-target bol eol)))))
259 (defun wl-highlight-plugged-current-line ()
262 (let ((inhibit-read-only t)
265 (when (looking-at "[ \t]*\\(\\[\\([^]]+\\)\\]\\)")
266 (setq switch (elmo-match-buffer 2))
267 (if (and (setq extent (extent-at (match-end 1) nil nil nil 'at))
268 (extent-end-glyph extent))
269 (delete-extent extent))
270 (setq extent (make-extent (match-beginning 1) (match-end 1)))
271 (set-extent-property extent 'end-open t)
272 (set-extent-property extent 'start-closed t)
273 (set-extent-property extent 'invisible t)
274 (set-extent-end-glyph extent (if (string= switch wl-plugged-plug-on)
276 wl-unplugged-glyph))))))
278 (defun wl-plugged-set-folder-icon (folder string)
279 (let ((string (copy-sequence string))
280 (len (length string))
282 (if (string= folder wl-queue-folder)
283 (put-text-property 0 len 'begin-glyph wl-folder-queue-glyph string)
284 (if (setq type (elmo-folder-get-type folder))
285 (put-text-property 0 len
288 (intern (format "wl-folder-%s-glyph" type)))
292 (defvar wl-folder-internal-icon-list
293 ;; alist of (glyph . icon-file)
294 '((wl-folder-nntp-glyph . wl-nntp-folder-icon)
295 (wl-folder-imap4-glyph . wl-imap-folder-icon)
296 (wl-folder-pop3-glyph . wl-pop-folder-icon)
297 (wl-folder-localdir-glyph . wl-localdir-folder-icon)
298 (wl-folder-localnews-glyph . wl-localnews-folder-icon)
299 (wl-folder-internal-glyph . wl-internal-folder-icon)
300 (wl-folder-multi-glyph . wl-multi-folder-icon)
301 (wl-folder-filter-glyph . wl-filter-folder-icon)
302 (wl-folder-archive-glyph . wl-archive-folder-icon)
303 (wl-folder-pipe-glyph . wl-pipe-folder-icon)
304 (wl-folder-maildir-glyph . wl-maildir-folder-icon)
305 (wl-folder-trash-empty-glyph . wl-empty-trash-folder-icon)
306 (wl-folder-draft-glyph . wl-draft-folder-icon)
307 (wl-folder-queue-glyph . wl-queue-folder-icon)
308 (wl-folder-trash-glyph . wl-trash-folder-icon)))
310 (defvar wl-folder-toggle-icon-list
311 '((wl-folder-opened-glyph . wl-opened-group-folder-icon)
312 (wl-folder-closed-glyph . wl-closed-group-folder-icon)))
314 (defun wl-xmas-make-icon-glyph (icon-string icon-file &optional locale tag-set)
315 (let ((glyph (make-glyph (vector 'string :data icon-string))))
316 (if wl-highlight-folder-with-icon
317 (set-glyph-image glyph
318 (vector 'xpm :file (expand-file-name
319 icon-file wl-icon-dir))
320 locale tag-set 'prepend))
323 (defun wl-folder-init-icons ()
326 (if (null (symbol-value (car x)))
327 (set (car x) (wl-xmas-make-icon-glyph "" (symbol-value (cdr x))))))
328 wl-folder-internal-icon-list))
330 (defun wl-plugged-init-icons ()
331 (if (null wl-plugged-glyph)
332 (setq wl-plugged-glyph
333 (wl-xmas-make-icon-glyph
334 (concat "[" wl-plugged-plug-on "]")
336 (if (null wl-unplugged-glyph)
337 (setq wl-unplugged-glyph
338 (wl-xmas-make-icon-glyph
339 (concat "[" wl-plugged-plug-off "]")
340 wl-unplugged-icon))))
342 (defun wl-make-modeline ()
343 "Make modeline for Wanderlust"
344 (wl-plugged-init-icons)
345 (let ((extent (make-extent nil nil))
346 (toggle-keymap (make-sparse-keymap)))
347 (define-key toggle-keymap 'button2 (make-modeline-command-wrapper
349 (set-extent-keymap extent toggle-keymap)
350 (set-extent-property extent 'help-echo "button2 toggles plugged status")
351 (setq wl-plug-state-indicator-on (cons extent wl-plugged-glyph))
352 (setq wl-plug-state-indicator-off (cons extent wl-unplugged-glyph))
353 (setq wl-plug-state-indicator (if wl-plugged
354 wl-plug-state-indicator-on
355 wl-plug-state-indicator-off)))
356 (wl-make-modeline-subr))
358 (defun wl-make-date-string ()
359 (let ((s (current-time-string)))
360 (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]"
362 (concat (wl-match-string 1 s) ", "
363 (timezone-make-date-arpa-standard s (current-time-zone)))))
366 (defun wl-xmas-setup-folder ()
367 (and (featurep 'scrollbar)
368 (set-specifier scrollbar-height (cons (current-buffer) 0)))
369 (wl-xmas-setup-folder-toolbar))
371 (defun wl-xmas-setup-summary ()
372 (make-local-variable 'dragdrop-drop-functions)
373 (setq dragdrop-drop-functions '((wl-dnd-default-drop-message t t)))
374 (and (featurep 'scrollbar)
375 (set-specifier scrollbar-height (cons (current-buffer) 0)))
376 (wl-xmas-setup-summary-toolbar))
378 (defun wl-message-overload-functions ()
379 (wl-xmas-setup-message-toolbar)
380 (local-set-key "l" 'wl-message-toggle-disp-summary)
381 (local-set-key 'button2 'wl-message-refer-article-or-url)
382 (local-set-key 'button4 'wl-message-wheel-down)
383 (local-set-key 'button5 'wl-message-wheel-up)
384 (local-set-key [(shift button4)] 'wl-message-wheel-down)
385 (local-set-key [(shift button5)] 'wl-message-wheel-up))
387 (defun wl-message-wheel-up (event)
389 (let ((cur-buf (current-buffer))
391 (save-selected-window
392 (select-window (event-window event))
394 (setq proceed (wl-message-next-page)))
396 (if (memq 'shift (event-modifiers event))
398 (wl-summary-next t)))))
400 (defun wl-message-wheel-down (event)
402 (let ((cur-buf (current-buffer))
404 (save-selected-window
405 (select-window (event-window event))
407 (setq proceed (wl-message-prev-page)))
409 (if (memq 'shift (event-modifiers event))
411 (wl-summary-prev t)))))
413 (defun wl-draft-overload-menubar ()
414 (add-menu-item '("Mail") "Send, Keep Editing"
415 'wl-draft-send t "Send Mail")
416 (add-menu-item '("Mail") "Send Message"
417 'wl-draft-send-and-exit t "Send and Exit")
418 (delete-menu-item '("Mail" "Send Mail"))
419 (delete-menu-item '("Mail" "Send and Exit"))
422 (defun wl-draft-mode-setup ()
424 (define-derived-mode wl-draft-mode mail-mode "Draft"
425 "draft mode for Wanderlust derived from mail mode.
426 See info under Wanderlust for full documentation.
429 \\{wl-draft-mode-map}"))
431 (defun wl-draft-key-setup ()
432 (define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
433 (define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
434 (define-key wl-draft-mode-map "\C-c\C-a" 'wl-draft-insert-x-face-field)
435 (define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
436 (define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
437 (define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
438 (define-key wl-draft-mode-map "\C-l" 'wl-draft-highlight-and-recenter)
439 (define-key wl-draft-mode-map "\C-i" 'wl-complete-field-body-or-tab)
440 (define-key wl-draft-mode-map "\C-c\C-r" 'wl-draft-caesar-region)
441 (define-key wl-draft-mode-map "\M-t" 'wl-toggle-plugged)
442 (define-key wl-draft-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
443 (define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
444 (define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
445 (define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
446 (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
447 (define-key wl-draft-mode-map "\C-xk" 'wl-draft-mimic-kill-buffer))
449 (defun wl-draft-overload-functions ()
450 (setq mode-line-buffer-identification
451 (format "Wanderlust: %s" (buffer-name)))
452 (local-set-key "\C-c\C-s" 'wl-draft-send) ; override
453 (wl-xmas-setup-draft-toolbar)
454 (wl-draft-overload-menubar)
455 (when wl-show-plug-status-on-modeline
456 (setq mode-line-format (wl-make-modeline))))
458 (defalias 'wl-defface 'defface)
462 ;;; wl-xmas.el ends here