-;;; wl-xmas.el -- Wanderlust modules for XEmacsen.
+;;; wl-xmas.el --- Wanderlust modules for XEmacsen.
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 2000, 2001, 2002, 2003 Katsumi Yamaoka <yamaoka@jpl.org>
;; Author: Yuuichi Teranishi <teranisi@gohome.org>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: mail, net news
-;; Time-stamp: <00/03/24 14:44:00 teranisi>
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
(eval-when-compile
(require 'wl-folder)
(require 'wl-summary)
- (require 'wl-draft)
+ (require 'wl-draft)
(require 'wl-message)
(require 'wl-highlight)
- (defvar-maybe wl-draft-mode-map (make-sparse-keymap)))
+ (defvar-maybe wl-draft-mode-map (make-sparse-keymap))
+ (defalias-maybe 'toolbar-make-button-list 'ignore))
-(defun wl-xmas-setup-toolbar (bar)
- (let ((dir wl-icon-dir)
- icon up down disabled name)
- (when dir
- (while bar
- (setq icon (aref (car bar) 0)
- name (symbol-name icon)
- bar (cdr bar))
- (when (not (boundp icon))
- (setq up (concat dir elmo-path-sep name "-up.xpm"))
- (setq down (concat dir elmo-path-sep name "-down.xpm"))
- (setq disabled (concat dir elmo-path-sep name "-disabled.xpm"))
- (if (not (file-exists-p up))
- (setq bar nil
- dir nil)
- (set icon (toolbar-make-button-list
- up (and (file-exists-p down) down)
- (and (file-exists-p disabled) disabled)))))))
- dir))
+(add-hook 'wl-folder-mode-hook 'wl-setup-folder)
+(add-hook 'wl-folder-mode-hook 'wl-folder-init-icons)
+
+(add-hook 'wl-init-hook 'wl-biff-init-icons)
+(add-hook 'wl-init-hook 'wl-plugged-init-icons)
+
+(add-hook 'wl-summary-mode-hook 'wl-setup-summary)
+
+(add-hook 'wl-message-display-internal-hook 'wl-setup-message)
(defvar wl-use-toolbar (if (featurep 'toolbar) 'default-toolbar nil))
(defvar wl-plugged-glyph nil)
(defvar wl-unplugged-glyph nil)
+(defvar wl-biff-mail-glyph nil)
+(defvar wl-biff-nomail-glyph nil)
(defvar wl-folder-toolbar
'([wl-folder-jump-to-current-entity
wl-folder-prev-entity t "Previous Folder"]
[wl-folder-check-current-entity
wl-folder-check-current-entity t "Check Current Folder"]
-; [wl-draft
-; wl-draft t "Write a New Message"]
[wl-folder-sync-current-entity
wl-folder-sync-current-entity t "Sync Current Folder"]
[wl-draft
wl-draft t "Write a New Message"]
+ [wl-folder-goto-draft-folder
+ wl-folder-goto-draft-folder t "Go to Draft Folder"]
[wl-folder-empty-trash
wl-folder-empty-trash t "Empty Trash"]
[wl-exit
wl-summary-jump-to-current-message t "Jump to Current Message"]
[wl-summary-sync-force-update
wl-summary-sync-force-update t "Sync Current Folder"]
- [wl-summary-delete
- wl-summary-delete t "Delete Current Message"]
- [wl-summary-mark-as-important
- wl-summary-mark-as-important t "Mark Current Message as Important"]
+ [wl-summary-dispose
+ wl-summary-dispose t "Dispose Current Message"]
+ [wl-summary-set-flags
+ wl-summary-set-flags t "Set Flags"]
[wl-draft
- wl-draft t "Write a New Message"]
+ wl-summary-write-current-folder t "Write for Current Folder"]
[wl-summary-reply
wl-summary-reply t "Reply to Current Message" ]
[wl-summary-reply-with-citation
[wl-summary-forward
wl-summary-forward t "Forward Current Message"]
[wl-summary-exit
- wl-summary-exit t "Exit Current Summary"]
+ wl-summary-exit t "Exit Current Summary"]
)
"The Summary buffer toolbar.")
)
"The Message buffer toolbar.")
-(defalias 'wl-draft-insert-signature 'insert-signature) ;; for draft toolbar.
+(defalias 'wl-draft-insert-signature 'insert-signature);; for draft toolbar.
(defvar wl-draft-toolbar
'([wl-draft-send-from-toolbar
wl-draft-insert-signature t "Insert Signature"]
[wl-draft-kill
wl-draft-kill t "Kill Current Draft"]
+ [wl-draft-save-and-exit
+ wl-draft-save-and-exit t "Save Draft and Exit"]
)
"The Draft buffer toolbar.")
-(defun wl-xmas-setup-folder-toolbar ()
- (and wl-use-toolbar
- (wl-xmas-setup-toolbar wl-folder-toolbar)
- (set-specifier (symbol-value wl-use-toolbar)
- (cons (current-buffer) wl-folder-toolbar))))
+(defun wl-xmas-setup-toolbar (bar)
+ (let ((dir wl-icon-directory)
+ icon up down disabled name)
+ (when dir
+ (while bar
+ (setq icon (aref (car bar) 0)
+ name (symbol-name icon)
+ bar (cdr bar))
+ (unless (boundp icon)
+ (setq up (expand-file-name (concat name "-up.xpm") dir)
+ down (expand-file-name (concat name "-down.xpm") dir)
+ disabled (expand-file-name (concat name "-disabled.xpm") dir))
+ (if (file-exists-p up)
+ (set icon (toolbar-make-button-list
+ up (and (file-exists-p down) down)
+ (and (file-exists-p disabled) disabled)))
+ (setq bar nil
+ dir nil)))))
+ dir))
-(defun wl-xmas-setup-summary-toolbar ()
- (and wl-use-toolbar
- (wl-xmas-setup-toolbar wl-summary-toolbar)
- (set-specifier (symbol-value wl-use-toolbar)
- (cons (current-buffer) wl-summary-toolbar))))
+(defun wl-xmas-make-icon-glyph (icon-string icon-file
+ &optional locale tag-set)
+ (let ((glyph (make-glyph (vector 'string :data icon-string))))
+ (when wl-highlight-folder-with-icon
+ (set-glyph-image glyph
+ (vector 'xpm :file (expand-file-name
+ icon-file wl-icon-directory))
+ locale tag-set 'prepend))
+ glyph))
+
+(eval-when-compile
+ (defsubst wl-xmas-setup-folder-toolbar ()
+ (and wl-use-toolbar
+ (wl-xmas-setup-toolbar wl-folder-toolbar)
+ (set-specifier (symbol-value wl-use-toolbar)
+ (cons (current-buffer) wl-folder-toolbar))))
+
+ (defsubst wl-xmas-setup-summary-toolbar ()
+ (and wl-use-toolbar
+ (wl-xmas-setup-toolbar wl-summary-toolbar)
+ (set-specifier (symbol-value wl-use-toolbar)
+ (cons (current-buffer) wl-summary-toolbar))))
+
+ (defsubst wl-xmas-setup-draft-toolbar ()
+ (and wl-use-toolbar
+ (wl-xmas-setup-toolbar wl-draft-toolbar)
+ (set-specifier (symbol-value wl-use-toolbar)
+ (cons (current-buffer) wl-draft-toolbar)))))
(defun wl-xmas-setup-message-toolbar ()
(and wl-use-toolbar
(set-specifier (symbol-value wl-use-toolbar)
(cons (current-buffer) wl-message-toolbar))))
-(defun wl-xmas-setup-draft-toolbar ()
- (and wl-use-toolbar
- (wl-xmas-setup-toolbar wl-draft-toolbar)
- (set-specifier (symbol-value wl-use-toolbar)
- (cons (current-buffer) wl-draft-toolbar))))
+(defvar wl-folder-toggle-icon-list
+ '((wl-folder-opened-glyph . wl-opened-group-folder-icon)
+ (wl-folder-closed-glyph . wl-closed-group-folder-icon)))
+
+(eval-when-compile
+ (defsubst wl-xmas-highlight-folder-group-line (glyph text-face numbers)
+ (let ((start (match-beginning 1))
+ (end (match-end 1)))
+ (let ((extent (or (map-extents
+ (lambda (extent maparg)
+ (and (eq start (extent-start-position extent))
+ (eq end (extent-end-position extent))
+ extent))
+ nil start start nil nil 'end-glyph)
+ (make-extent start end))))
+ (set-extent-properties extent `(end-open t start-closed t invisible t))
+ (set-extent-end-glyph
+ extent
+ (or (get glyph 'glyph)
+ (put glyph 'glyph
+ (wl-xmas-make-icon-glyph
+ (buffer-substring-no-properties start end)
+ (symbol-value
+ (cdr (assq glyph wl-folder-toggle-icon-list))))))))
+ (let ((inhibit-read-only t))
+ (when wl-use-highlight-mouse-line
+ (put-text-property start (point-at-eol) 'mouse-face 'highlight))
+ (setq start end
+ end (point-at-eol))
+ (if (and wl-highlight-folder-by-numbers
+ numbers (nth 0 numbers) (nth 1 numbers)
+ (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" end t))
+ (let* ((unsync (nth 0 numbers))
+ (unread (nth 1 numbers))
+ (face (cond ((and unsync (zerop unsync))
+ (if (and unread (zerop unread))
+ 'wl-highlight-folder-zero-face
+ 'wl-highlight-folder-unread-face))
+ ((and unsync
+ (>= unsync
+ wl-folder-many-unsync-threshold))
+ 'wl-highlight-folder-many-face)
+ (t
+ 'wl-highlight-folder-few-face))))
+ (if (numberp wl-highlight-folder-by-numbers)
+ (progn
+ (put-text-property start (match-beginning 0)
+ 'face text-face)
+ (put-text-property (match-beginning 0) (point) 'face face))
+ (put-text-property start end 'face face)))
+ (put-text-property start end 'face text-face))))))
-;; XEmacs implementations.
(defun wl-highlight-folder-current-line (&optional numbers)
(interactive)
(save-excursion
- (let ((highlights (list "opened" "closed"))
- (inhibit-read-only t)
- (fld-name (wl-folder-get-folder-name-by-id
- (get-text-property (point) 'wl-folder-entity-id)))
- fregexp fsymbol bol eol matched type extent num type glyph)
- (setq eol (progn (end-of-line) (point))
- bol (progn (beginning-of-line) (point)))
- (when (and fld-name (looking-at "[ \t]+\\([^ \t]+\\)"))
- (if (and (setq extent (extent-at (match-beginning 1) nil nil nil 'at))
- (extent-begin-glyph extent))
- (delete-extent extent))
- (setq extent (make-extent (match-beginning 1) (match-beginning 1)))
- (cond
- ((string= fld-name wl-trash-folder) ;; set trash folder icon
- (setq num (nth 2 numbers)) ;; number of messages
- (set-extent-begin-glyph extent
- (if (or (null num)
- (eq num 0))
- wl-folder-trash-empty-glyph
- wl-folder-trash-glyph)))
- ((string= fld-name wl-draft-folder) ;; set draft folder icon
- (set-extent-begin-glyph extent wl-folder-draft-glyph))
- ((string= fld-name wl-queue-folder)
- (set-extent-begin-glyph extent wl-folder-queue-glyph))
- ((and (setq type (elmo-folder-get-type fld-name))
- (or numbers ;; XXX dirty...!!
- (not (assoc fld-name wl-folder-group-alist))))
- ;; not group folder.
- (set-extent-begin-glyph extent
- (symbol-value
- (intern (format "wl-folder-%s-glyph"
- type)))))))
- (when (and numbers (nth 0 numbers) (nth 1 numbers))
- (setq fsymbol
- (let ((unsync (nth 0 numbers))
- (unread (nth 1 numbers)))
- (cond ((and unsync (eq unsync 0))
- (if (and unread (> unread 0))
- 'wl-highlight-folder-unread-face
- 'wl-highlight-folder-zero-face))
- ((and unsync
- (>= unsync wl-folder-many-unsync-threshold))
- 'wl-highlight-folder-many-face)
- (t
- 'wl-highlight-folder-few-face))))
- (put-text-property bol eol 'face nil)
- (put-text-property bol eol 'face fsymbol)
- (setq matched t))
- (while highlights
- (setq fregexp (symbol-value
- (intern (format "wl-highlight-folder-%s-regexp"
- (car highlights)))))
- (if (not wl-highlight-group-folder-by-numbers)
- (setq fsymbol (intern (format "wl-highlight-folder-%s-face"
- (car highlights)))))
- (when (looking-at fregexp)
- (setq extent (make-extent (match-beginning 1) (match-end 1))
- glyph (intern (format "wl-folder-%s-glyph"
- (car highlights))))
- (if (null (symbol-value glyph))
- (set glyph (wl-xmas-make-icon-glyph
- (extent-string extent)
- (symbol-value
- (cdr (assq glyph wl-folder-toggle-icon-list))))))
- (setq glyph (symbol-value glyph))
- (set-extent-property extent 'end-open t)
- (set-extent-property extent 'start-closed t)
- (set-extent-property extent 'invisible t)
- (set-extent-end-glyph extent glyph)
- (put-text-property bol eol 'face nil)
- (put-text-property bol eol 'face fsymbol)
- (setq matched t highlights nil))
- (setq highlights (cdr highlights)))
- (when (not matched)
- (put-text-property bol eol 'face nil)
- (if (looking-at (format "^[ ]*\\(%s\\|%s\\)"
- wl-folder-unsubscribe-mark
- wl-folder-removed-mark))
- (put-text-property bol eol 'face
- 'wl-highlight-folder-killed-face)
- (put-text-property bol eol 'face
- 'wl-highlight-folder-unknown-face)))
- (if wl-use-highlight-mouse-line
- (wl-highlight-folder-mouse-line))
- (if (and (featurep 'dragdrop) wl-use-dnd)
- (wl-dnd-set-drop-target bol eol)))))
+ (beginning-of-line)
+ (let (fld-name)
+ (cond
+ (;; opened folder group
+ (and (wl-folder-buffer-group-p)
+ (looking-at wl-highlight-folder-opened-regexp))
+ (wl-xmas-highlight-folder-group-line 'wl-folder-opened-glyph
+ 'wl-highlight-folder-opened-face
+ numbers))
+ (;; closed folder group
+ (and (wl-folder-buffer-group-p)
+ (looking-at wl-highlight-folder-closed-regexp))
+ (wl-xmas-highlight-folder-group-line 'wl-folder-closed-glyph
+ 'wl-highlight-folder-closed-face
+ numbers))
+ (;; basic folder
+ (and (setq fld-name (wl-folder-get-folder-name-by-id
+ (get-text-property (point) 'wl-folder-entity-id)))
+ (looking-at "[ \t]+\\([^ \t]+\\)"))
+ (let ((start (match-beginning 1)))
+ (let ((extent (or (map-extents
+ (lambda (extent maparg)
+ (and (eq start (extent-start-position extent))
+ (eq start (extent-end-position extent))
+ extent))
+ nil start start nil nil 'begin-glyph)
+ (make-extent start start))))
+ (let (type)
+ (set-extent-begin-glyph
+ extent
+ (cond
+ ((string= fld-name wl-trash-folder);; trash folder
+ (let ((num (nth 2 numbers)));; number of messages
+ (get (if (or (not num) (zerop num))
+ 'wl-folder-trash-empty-glyph
+ 'wl-folder-trash-glyph)
+ 'glyph)))
+ ((string= fld-name wl-draft-folder);; draft folder
+ (get 'wl-folder-draft-glyph 'glyph))
+ ((string= fld-name wl-queue-folder);; queue folder
+ (get 'wl-folder-queue-glyph 'glyph))
+ (;; and one of many other folders
+ (setq type (elmo-folder-type fld-name))
+ (get (intern (format "wl-folder-%s-glyph" type)) 'glyph))))))
+ (let ((end (point-at-eol)))
+ (when wl-use-highlight-mouse-line
+ (put-text-property start end 'mouse-face 'highlight))
+ (let ((text-face
+ (if (looking-at (format "^[ \t]*\\(?:%s\\|%s\\)"
+ wl-folder-unsubscribe-mark
+ wl-folder-removed-mark))
+ 'wl-highlight-folder-killed-face
+ 'wl-highlight-folder-unknown-face)))
+ (if (and wl-highlight-folder-by-numbers
+ numbers (nth 0 numbers) (nth 1 numbers)
+ (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" end t))
+ (let* ((unsync (nth 0 numbers))
+ (unread (nth 1 numbers))
+ (face (cond
+ ((and unsync (zerop unsync))
+ (if (and unread (zerop unread))
+ 'wl-highlight-folder-zero-face
+ 'wl-highlight-folder-unread-face))
+ ((and unsync
+ (>= unsync
+ wl-folder-many-unsync-threshold))
+ 'wl-highlight-folder-many-face)
+ (t
+ 'wl-highlight-folder-few-face))))
+ (if (numberp wl-highlight-folder-by-numbers)
+ (progn
+ (put-text-property start (match-beginning 0)
+ 'face text-face)
+ (put-text-property (match-beginning 0)
+ (match-end 0)
+ 'face face))
+ ;; Remove previous face.
+ (put-text-property start (match-end 0) 'face nil)
+ (put-text-property start (match-end 0) 'face face)))
+ (put-text-property start end 'face text-face))))))))))
(defun wl-highlight-plugged-current-line ()
(interactive)
(beginning-of-line)
(when (looking-at "[ \t]*\\(\\[\\([^]]+\\)\\]\\)")
(setq switch (elmo-match-buffer 2))
- (if (and (setq extent (extent-at (match-end 1) nil nil nil 'at))
- (extent-end-glyph extent))
- (delete-extent extent))
+ (when (and (setq extent (extent-at (match-end 1) nil nil nil 'at))
+ (extent-end-glyph extent))
+ (delete-extent extent))
(setq extent (make-extent (match-beginning 1) (match-end 1)))
(set-extent-property extent 'end-open t)
(set-extent-property extent 'start-closed t)
(len (length string))
type)
(if (string= folder wl-queue-folder)
- (put-text-property 0 len 'begin-glyph wl-folder-queue-glyph string)
- (if (setq type (elmo-folder-get-type folder))
+ (put-text-property 0 len 'begin-glyph
+ (get 'wl-folder-queue-glyph 'glyph)
+ string)
+ (if (setq type (elmo-folder-type folder))
(put-text-property 0 len
'begin-glyph
- (symbol-value
- (intern (format "wl-folder-%s-glyph" type)))
+ (get (intern (format "wl-folder-%s-glyph" type))
+ 'glyph)
string)))
string))
(defvar wl-folder-internal-icon-list
;; alist of (glyph . icon-file)
- '((wl-folder-nntp-glyph . wl-nntp-folder-icon)
- (wl-folder-imap4-glyph . wl-imap-folder-icon)
- (wl-folder-pop3-glyph . wl-pop-folder-icon)
- (wl-folder-localdir-glyph . wl-localdir-folder-icon)
- (wl-folder-localnews-glyph . wl-localnews-folder-icon)
- (wl-folder-internal-glyph . wl-internal-folder-icon)
- (wl-folder-multi-glyph . wl-multi-folder-icon)
- (wl-folder-filter-glyph . wl-filter-folder-icon)
- (wl-folder-archive-glyph . wl-archive-folder-icon)
- (wl-folder-pipe-glyph . wl-pipe-folder-icon)
- (wl-folder-maildir-glyph . wl-maildir-folder-icon)
- (wl-folder-trash-empty-glyph . wl-empty-trash-folder-icon)
- (wl-folder-draft-glyph . wl-draft-folder-icon)
- (wl-folder-queue-glyph . wl-queue-folder-icon)
- (wl-folder-trash-glyph . wl-trash-folder-icon)))
-
-(defvar wl-folder-toggle-icon-list
- '((wl-folder-opened-glyph . wl-opened-group-folder-icon)
- (wl-folder-closed-glyph . wl-closed-group-folder-icon)))
-
-(defun wl-xmas-make-icon-glyph (icon-string icon-file &optional locale tag-set)
- (let ((glyph (make-glyph (vector 'string :data icon-string))))
- (if wl-highlight-folder-with-icon
- (set-glyph-image glyph
- (vector 'xpm :file (expand-file-name
- icon-file wl-icon-dir))
- locale tag-set 'prepend))
- glyph))
-
-(defun wl-folder-init-icons ()
- (mapcar
- (lambda (x)
- (if (null (symbol-value (car x)))
- (set (car x) (wl-xmas-make-icon-glyph "" (symbol-value (cdr x))))))
- wl-folder-internal-icon-list))
+ '((wl-folder-nntp-glyph . wl-nntp-folder-icon)
+ (wl-folder-imap4-glyph . wl-imap-folder-icon)
+ (wl-folder-pop3-glyph . wl-pop-folder-icon)
+ (wl-folder-localdir-glyph . wl-localdir-folder-icon)
+ (wl-folder-localnews-glyph . wl-localnews-folder-icon)
+ (wl-folder-internal-glyph . wl-internal-folder-icon)
+ (wl-folder-multi-glyph . wl-multi-folder-icon)
+ (wl-folder-filter-glyph . wl-filter-folder-icon)
+ (wl-folder-archive-glyph . wl-archive-folder-icon)
+ (wl-folder-pipe-glyph . wl-pipe-folder-icon)
+ (wl-folder-maildir-glyph . wl-maildir-folder-icon)
+ (wl-folder-nmz-glyph . wl-nmz-folder-icon)
+ (wl-folder-shimbun-glyph . wl-shimbun-folder-icon)
+ (wl-folder-file-glyph . wl-file-folder-icon)
+ (wl-folder-trash-empty-glyph . wl-empty-trash-folder-icon)
+ (wl-folder-draft-glyph . wl-draft-folder-icon)
+ (wl-folder-queue-glyph . wl-queue-folder-icon)
+ (wl-folder-trash-glyph . wl-trash-folder-icon)))
+
+(defun wl-folder-init-icons ()
+ (dolist (icon wl-folder-internal-icon-list)
+ (unless (get (car icon) 'glyph)
+ (put (car icon) 'glyph
+ (wl-xmas-make-icon-glyph "" (symbol-value (cdr icon)))))))
(defun wl-plugged-init-icons ()
- (if (null wl-plugged-glyph)
- (setq wl-plugged-glyph
- (wl-xmas-make-icon-glyph
- (concat "[" wl-plugged-plug-on "]")
- wl-plugged-icon)))
- (if (null wl-unplugged-glyph)
- (setq wl-unplugged-glyph
- (wl-xmas-make-icon-glyph
- (concat "[" wl-plugged-plug-off "]")
- wl-unplugged-icon))))
-
-(defun wl-make-modeline ()
- "Make modeline for Wanderlust"
- (wl-plugged-init-icons)
- (let ((extent (make-extent nil nil))
- (toggle-keymap (make-sparse-keymap)))
- (define-key toggle-keymap 'button2 (make-modeline-command-wrapper
- 'wl-toggle-plugged))
- (set-extent-keymap extent toggle-keymap)
- (set-extent-property extent 'help-echo "button2 toggles plugged status")
- (setq wl-plug-state-indicator-on (cons extent wl-plugged-glyph))
- (setq wl-plug-state-indicator-off (cons extent wl-unplugged-glyph))
- (setq wl-plug-state-indicator (if wl-plugged
- wl-plug-state-indicator-on
- wl-plug-state-indicator-off)))
- (wl-make-modeline-subr))
+ (unless wl-plugged-glyph
+ (setq wl-plugged-glyph (wl-xmas-make-icon-glyph
+ wl-plug-state-indicator-on wl-plugged-icon)
+ wl-unplugged-glyph (wl-xmas-make-icon-glyph
+ wl-plug-state-indicator-off wl-unplugged-icon))
+ (let ((extent (make-extent nil nil)))
+ (let ((keymap (make-sparse-keymap)))
+ (define-key keymap 'button2
+ (make-modeline-command-wrapper 'wl-toggle-plugged))
+ (set-extent-keymap extent keymap)
+ (set-extent-property extent 'help-echo
+ "button2 toggles plugged status"))
+ (setq wl-modeline-plug-state-on (cons extent wl-plugged-glyph)
+ wl-modeline-plug-state-off (cons extent wl-unplugged-glyph)))))
+
+(defun wl-biff-init-icons ()
+ (unless wl-biff-mail-glyph
+ (setq wl-biff-mail-glyph (wl-xmas-make-icon-glyph
+ wl-biff-state-indicator-on
+ wl-biff-mail-icon)
+ wl-biff-nomail-glyph (wl-xmas-make-icon-glyph
+ wl-biff-state-indicator-off
+ wl-biff-nomail-icon))
+ (let ((extent (make-extent nil nil)))
+ (let ((keymap (make-sparse-keymap)))
+ (define-key keymap 'button2
+ (make-modeline-command-wrapper 'wl-biff-check-folders))
+ (set-extent-keymap extent keymap)
+ (set-extent-property extent 'help-echo "button2 checks new mails"))
+ (setq wl-modeline-biff-state-on (cons extent wl-biff-mail-glyph)
+ wl-modeline-biff-state-off (cons extent wl-biff-nomail-glyph)))))
(defun wl-make-date-string ()
(let ((s (current-time-string)))
(concat (wl-match-string 1 s) ", "
(timezone-make-date-arpa-standard s (current-time-zone)))))
-
-(defun wl-xmas-setup-folder ()
+(defun wl-setup-folder ()
(and (featurep 'scrollbar)
(set-specifier scrollbar-height (cons (current-buffer) 0)))
(wl-xmas-setup-folder-toolbar))
-(defun wl-xmas-setup-summary ()
+(defvar dragdrop-drop-functions)
+
+(defun wl-setup-summary ()
(make-local-variable 'dragdrop-drop-functions)
(setq dragdrop-drop-functions '((wl-dnd-default-drop-message t t)))
(and (featurep 'scrollbar)
(set-specifier scrollbar-height (cons (current-buffer) 0)))
(wl-xmas-setup-summary-toolbar))
-(defun wl-message-overload-functions ()
- (wl-xmas-setup-message-toolbar)
- (local-set-key "l" 'wl-message-toggle-disp-summary)
- (local-set-key 'button2 'wl-message-refer-article-or-url)
- (local-set-key 'button4 'wl-message-wheel-down)
- (local-set-key 'button5 'wl-message-wheel-up)
- (local-set-key [(shift button4)] 'wl-message-wheel-down)
- (local-set-key [(shift button5)] 'wl-message-wheel-up))
+(defalias 'wl-setup-message 'wl-xmas-setup-message-toolbar)
+
+(defun wl-message-define-keymap ()
+ (let ((keymap (make-sparse-keymap)))
+ (define-key keymap "D" 'wl-message-delete-current-part)
+ (define-key keymap "l" 'wl-message-toggle-disp-summary)
+ (define-key keymap "\C-c:d" 'wl-message-decrypt-pgp-nonmime)
+ (define-key keymap "\C-c:v" 'wl-message-verify-pgp-nonmime)
+ (define-key keymap 'button4 'wl-message-wheel-down)
+ (define-key keymap 'button5 'wl-message-wheel-up)
+ (define-key keymap [(shift button4)] 'wl-message-wheel-down)
+ (define-key keymap [(shift button5)] 'wl-message-wheel-up)
+ (set-keymap-parent wl-message-button-map keymap)
+ (define-key wl-message-button-map 'button2
+ 'wl-message-button-dispatcher)
+ keymap))
(defun wl-message-wheel-up (event)
(interactive "e")
- (let ((cur-buf (current-buffer))
- proceed)
- (save-selected-window
- (select-window (event-window event))
- (set-buffer cur-buf)
- (setq proceed (wl-message-next-page)))
- (if proceed
+ (if (string-match (regexp-quote wl-message-buffer-name)
+ (regexp-quote (buffer-name)))
+ (wl-message-prev-page)
+ (let ((cur-buf (current-buffer))
+ proceed)
+ (save-selected-window
+ (select-window (event-window event))
+ (set-buffer cur-buf)
+ (setq proceed (wl-message-next-page)))
+ (when proceed
(if (memq 'shift (event-modifiers event))
(wl-summary-down t)
- (wl-summary-next t)))))
+ (wl-summary-next t))))))
(defun wl-message-wheel-down (event)
(interactive "e")
- (let ((cur-buf (current-buffer))
- proceed)
- (save-selected-window
- (select-window (event-window event))
- (set-buffer cur-buf)
- (setq proceed (wl-message-prev-page)))
- (if proceed
+ (if (string-match (regexp-quote wl-message-buffer-name)
+ (regexp-quote (buffer-name)))
+ (wl-message-prev-page)
+ (let ((cur-buf (current-buffer))
+ proceed)
+ (save-selected-window
+ (select-window (event-window event))
+ (set-buffer cur-buf)
+ (setq proceed (wl-message-prev-page)))
+ (when proceed
(if (memq 'shift (event-modifiers event))
(wl-summary-up t)
- (wl-summary-prev t)))))
+ (wl-summary-prev t))))))
(defun wl-draft-overload-menubar ()
- (add-menu-item '("Mail") "Send, Keep Editing"
- 'wl-draft-send t "Send Mail")
- (add-menu-item '("Mail") "Send Message"
- 'wl-draft-send-and-exit t "Send and Exit")
- (delete-menu-item '("Mail" "Send Mail"))
- (delete-menu-item '("Mail" "Send and Exit"))
- )
+ (when (featurep 'menubar)
+ (add-menu-item '("Mail") "Send, Keep Editing"
+ 'wl-draft-send t "Send Mail")
+ (add-menu-item '("Mail") "Send Message"
+ 'wl-draft-send-and-exit t "Send and Exit")
+ (delete-menu-item '("Mail" "Send Mail"))
+ (delete-menu-item '("Mail" "Send and Exit"))
+ (add-menu-item '("Mail") "Preview Message"
+ 'wl-draft-preview-message t "Cancel")
+ (add-menu-item '("Mail") "Save Draft and Exit"
+ 'wl-draft-save-and-exit t "Cancel")
+ (add-menu-item '("Mail") "Kill Current Draft"
+ 'wl-draft-kill t "Cancel")
+ (delete-menu-item '("Mail" "Cancel"))))
(defun wl-draft-mode-setup ()
(require 'derived)
(defun wl-draft-key-setup ()
(define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
(define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
- (define-key wl-draft-mode-map "\C-c\C-a" 'wl-draft-insert-x-face-field)
(define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
(define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
(define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
(define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
(define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
(define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
- (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
- (define-key wl-draft-mode-map "\C-xk" 'wl-draft-mimic-kill-buffer))
+;; (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
+ (define-key wl-draft-mode-map "\C-c\C-a" 'wl-addrmgr)
+ (define-key wl-draft-mode-map "\C-xk" 'wl-draft-mimic-kill-buffer)
+ (define-key wl-draft-mode-map "\C-c\C-d" 'wl-draft-elide-region)
+ (define-key wl-draft-mode-map "\C-a" 'wl-draft-beginning-of-line)
+ (define-key wl-draft-mode-map "\M-p" 'wl-draft-previous-history-element)
+ (define-key wl-draft-mode-map "\M-n" 'wl-draft-next-history-element))
(defun wl-draft-overload-functions ()
- (setq mode-line-buffer-identification
- (format "Wanderlust: %s" (buffer-name)))
- (local-set-key "\C-c\C-s" 'wl-draft-send) ; override
+ (wl-mode-line-buffer-identification)
+ ;; (local-set-key "\C-c\C-s" 'wl-draft-send);; override
(wl-xmas-setup-draft-toolbar)
- (wl-draft-overload-menubar)
- (when wl-show-plug-status-on-modeline
- (setq mode-line-format (wl-make-modeline))))
+ (wl-draft-overload-menubar))
(defalias 'wl-defface 'defface)
-(provide 'wl-xmas)
+(defun wl-read-event-char ()
+ "Get the next event."
+ (let ((event (next-command-event)))
+ (sit-for 0)
+ ;; We junk all non-key events. Is this naughty?
+ (while (not (or (key-press-event-p event)
+ (button-press-event-p event)))
+ (dispatch-event event)
+ (setq event (next-command-event)))
+ (cons (and (key-press-event-p event)
+ (event-to-character event))
+ event)))
+
+(require 'product)
+(product-provide (provide 'wl-xmas) (require 'wl-version))
;;; wl-xmas.el ends here
projects / elisp / wanderlust.git / blobdiff