X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-e21.el;h=f5db2f667d2ee4d8386393f9698ac4e5236f2171;hb=255041087c1dab2d275ab4e1869d7df19cce007d;hp=7767bca14b7bdebcbf2a4679bc32d39b4256f81d;hpb=381e2a97cad59f2ec2f1f40e7c23e107ecee9ba8;p=elisp%2Fwanderlust.git diff --git a/wl/wl-e21.el b/wl/wl-e21.el index 7767bca..f5db2f6 100644 --- a/wl/wl-e21.el +++ b/wl/wl-e21.el @@ -69,7 +69,6 @@ (require 'wl-draft) (require 'wl-message) (require 'wl-highlight) - (defvar-maybe wl-folder-mode-map (make-sparse-keymap)) (defvar-maybe wl-draft-mode-map (make-sparse-keymap))) (add-hook 'wl-folder-mode-hook 'wl-setup-folder) @@ -97,12 +96,12 @@ 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 @@ -121,12 +120,12 @@ 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 @@ -154,7 +153,7 @@ ) "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 @@ -165,19 +164,29 @@ 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.") (eval-when-compile (defmacro wl-e21-display-image-p () - '(and (display-images-p) + '(and wl-highlight-folder-with-icon (image-type-available-p 'xpm)))) +(eval-and-compile + (if (boundp 'image-load-path) + (defun wl-e21-find-image (specs) + (let ((image-load-path (cons 'wl-icon-directory image-load-path))) + (find-image specs))) + (defun wl-e21-find-image (specs) + (let ((load-path (cons wl-icon-directory load-path))) + (find-image specs))))) + (defun wl-e21-setup-toolbar (bar) (when (and wl-use-toolbar (wl-e21-display-image-p)) - (let ((load-path (cons wl-icon-directory load-path)) - (props '(:type xpm :ascent center + (let ((props '(:type xpm :ascent center :color-symbols (("backgroundToolBarColor" . "None")) :file)) (success t) @@ -186,13 +195,16 @@ (setq icon (aref (pop bar) 0)) (unless (boundp icon) (setq name (symbol-name icon) - up (find-image `((,@props ,(concat name "-up.xpm"))))) + up (wl-e21-find-image `((,@props ,(concat name "-up.xpm"))))) (if up (progn - (setq down (find-image `((,@props ,(concat name "-down.xpm")))) - disabled (find-image + (setq down (wl-e21-find-image + `((,@props ,(concat name "-down.xpm")))) + disabled (wl-e21-find-image `((,@props ,(concat name "-disabled.xpm"))))) - (set icon (vector down up disabled disabled))) + (if (and down disabled) + (set icon (vector down up disabled disabled)) + (set icon up))) (setq bar nil success nil)))) success))) @@ -200,9 +212,10 @@ (defvar wl-e21-toolbar-configurations '((auto-resize-tool-bars . t) (auto-raise-tool-bar-buttons . t) - (tool-bar-button-margin . 0) - (tool-bar-button-relief . 2))) + (tool-bar-button-margin . 2) + (tool-bar-button-relief . 1))) +;; FIXME: this function should be rewritten in a proper way. (defun wl-e21-make-toolbar-buttons (keymap defs) (let ((configs wl-e21-toolbar-configurations) config) @@ -213,16 +226,18 @@ item) (while (setq item (pop keys)) (when (setq item (car-safe item)) - (define-key keymap (vector 'tool-bar item) 'undefined)))) + (ignore-errors ;; workaround + (define-key keymap (vector 'tool-bar item) 'undefined))))) (let ((n (length defs)) def) (while (>= n 0) (setq n (1- n) def (nth n defs)) - (define-key keymap (vector 'tool-bar (aref def 1)) - (list 'menu-item (aref def 3) (aref def 1) - :enable (aref def 2) - :image (symbol-value (aref def 0))))))) + (ignore-errors ;; workaround + (define-key keymap (vector 'tool-bar (aref def 1)) + (list 'menu-item (aref def 3) (aref def 1) + :enable (aref def 2) + :image (symbol-value (aref def 0)))))))) (defun wl-e21-setup-folder-toolbar () (when (wl-e21-setup-toolbar wl-folder-toolbar) @@ -247,33 +262,30 @@ (eval-when-compile (defsubst wl-e21-highlight-folder-group-line (start end icon numbers) - (when (wl-e21-display-image-p) - (let (overlay) - (let ((overlays (overlays-in start end))) - (while (and (setq overlay (pop overlays)) - (not (overlay-get overlay 'wl-e21-icon))))) - (unless overlay - (setq overlay (make-overlay start end)) - (overlay-put overlay 'wl-e21-icon t) - (overlay-put overlay 'evaporate t)) - (let ((image (get icon 'image))) + (let (image) + (when (wl-e21-display-image-p) + (let (overlay) + (let ((overlays (overlays-in start end))) + (while (and (setq overlay (pop overlays)) + (not (overlay-get overlay 'wl-e21-icon))))) + (unless overlay + (setq overlay (make-overlay start end)) + (overlay-put overlay 'wl-e21-icon t) + (overlay-put overlay 'evaporate t)) + (setq image (get icon 'image)) (unless image (let ((name (symbol-value - (cdr (assq icon wl-folder-toggle-icon-list)))) - (load-path (cons wl-icon-directory load-path))) - (when (setq image (find-image `((:type xpm :file ,name - :ascent center)))) - (setq image (put icon 'image (propertize name - 'display image)))))) - (overlay-put overlay 'before-string image) - (overlay-put overlay 'invisible (and image t)) - (when (and wl-use-highlight-mouse-line (display-mouse-p)) - (let ((inhibit-read-only t)) - (put-text-property (if image - (max (1- start) (line-beginning-position)) - start) - (line-end-position) - 'mouse-face 'highlight))))))) + (cdr (assq icon wl-folder-toggle-icon-list))))) + (setq image (wl-e21-find-image + `((:type xpm :file ,name :ascent center)))))) + (overlay-put overlay 'display image))) + (when (and wl-use-highlight-mouse-line (display-mouse-p)) + (let ((inhibit-read-only t)) + (put-text-property (if image + (max (1- start) (line-beginning-position)) + start) + (line-end-position) + 'mouse-face 'highlight))))) (defsubst wl-e21-highlight-folder-by-numbers (start end text-face numbers) (when (display-color-p) @@ -309,8 +321,9 @@ (beginning-of-line) (let (fld-name start end) (cond - (;; opened folder group - (looking-at wl-highlight-folder-opened-regexp) + ;; opened folder group + ((and (wl-folder-buffer-group-p) + (looking-at wl-highlight-folder-opened-regexp)) (setq start (match-beginning 1) end (match-end 1)) (wl-e21-highlight-folder-group-line start end @@ -319,8 +332,9 @@ (wl-e21-highlight-folder-by-numbers start end 'wl-highlight-folder-opened-face numbers)) - (;; closed folder group - (looking-at wl-highlight-folder-closed-regexp) + ;; closed folder group + ((and (wl-folder-buffer-group-p) + (looking-at wl-highlight-folder-closed-regexp)) (setq start (match-beginning 1) end (match-end 1)) (wl-e21-highlight-folder-group-line start end @@ -329,8 +343,8 @@ (wl-e21-highlight-folder-by-numbers start end 'wl-highlight-folder-closed-face numbers)) - (;; basic folder - (and (setq fld-name (wl-folder-get-folder-name-by-id + ;; basic folder + ((and (setq fld-name (wl-folder-get-folder-name-by-id (get-text-property (point) 'wl-folder-entity-id))) (looking-at "[[:blank:]]+\\([^[:blank:]\n]+\\)")) (setq start (match-beginning 1) @@ -349,21 +363,29 @@ (unless (get (caar wl-folder-internal-icon-list) 'image) (wl-folder-init-icons)) (setq image - (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-image - 'wl-folder-trash-image) - 'image))) - ((string= fld-name wl-draft-folder);; draft folder - (get 'wl-folder-draft-image 'image)) - ((string= fld-name wl-queue-folder);; queue folder - (get 'wl-folder-queue-image 'image)) - (;; and one of many other folders - (setq type (elmo-folder-type fld-name)) - (get (intern (format "wl-folder-%s-image" type)) - 'image))))) - (overlay-put overlay 'before-string image))) + (cond + ;; trash folder + ((string= fld-name wl-trash-folder) + (let ((num (nth 2 numbers))) ; number of messages + (get (if (or (not num) (zerop num)) + 'wl-folder-trash-empty-image + 'wl-folder-trash-image) + 'image))) + ;; draft folder + ((string= fld-name wl-draft-folder) + (get 'wl-folder-draft-image 'image)) + ;; queue folder + ((string= fld-name wl-queue-folder) + (get 'wl-folder-queue-image 'image)) + ;; and one of many other folders + ((setq type (or (elmo-folder-type fld-name) + (elmo-folder-type-internal + (elmo-make-folder fld-name)))) + (get (intern (format "wl-folder-%s-image" type)) + 'image))))) + (overlay-put overlay 'before-string + (propertize " " 'display image + 'invisible t)))) (when (and wl-use-highlight-mouse-line (display-mouse-p)) (let ((inhibit-read-only t)) (put-text-property (if image @@ -403,56 +425,56 @@ (setq overlay (make-overlay start end)) (overlay-put overlay 'wl-e21-icon t) (overlay-put overlay 'evaporate t)) - (put-text-property 0 (length status) 'display image status) - (overlay-put overlay 'before-string status) - (overlay-put overlay 'invisible t)))))))) + (overlay-put overlay 'display image)))))))) (defun wl-plugged-set-folder-icon (folder string) - (if (wl-e21-display-image-p) - (let (type) - (cond ((string= folder wl-queue-folder) - (concat (get 'wl-folder-queue-image 'image) - string)) - ((setq type (elmo-folder-type folder)) - (concat (get (intern (format "wl-folder-%s-image" - type)) - 'image) - string)) - (t - string))) - string)) + (let (image type) + (when (wl-e21-display-image-p) + (setq image + (cond ((string= folder wl-queue-folder) + (get 'wl-folder-queue-image 'image)) + ((setq type (or (elmo-folder-type folder) + (elmo-folder-type-internal + (elmo-make-folder folder)))) + (get (intern (format "wl-folder-%s-image" type)) + 'image))))) + (if image + (concat (propertize " " 'display image 'invisible t) string) + string))) (defvar wl-folder-internal-icon-list ;; alist of (image . icon-file) - '((wl-folder-nntp-image . wl-nntp-folder-icon) - (wl-folder-imap4-image . wl-imap-folder-icon) - (wl-folder-pop3-image . wl-pop-folder-icon) + '((wl-folder-nntp-image . wl-nntp-folder-icon) + (wl-folder-imap4-image . wl-imap-folder-icon) + (wl-folder-pop3-image . wl-pop-folder-icon) (wl-folder-localdir-image . wl-localdir-folder-icon) (wl-folder-localnews-image . wl-localnews-folder-icon) (wl-folder-internal-image . wl-internal-folder-icon) - (wl-folder-multi-image . wl-multi-folder-icon) + (wl-folder-multi-image . wl-multi-folder-icon) (wl-folder-filter-image . wl-filter-folder-icon) (wl-folder-archive-image . wl-archive-folder-icon) - (wl-folder-pipe-image . wl-pipe-folder-icon) + (wl-folder-pipe-image . wl-pipe-folder-icon) (wl-folder-maildir-image . wl-maildir-folder-icon) - (wl-folder-nmz-image . wl-nmz-folder-icon) + (wl-folder-search-image . wl-search-folder-icon) (wl-folder-shimbun-image . wl-shimbun-folder-icon) + (wl-folder-file-image . wl-file-folder-icon) + (wl-folder-access-image . wl-access-folder-icon) (wl-folder-trash-empty-image . wl-empty-trash-folder-icon) - (wl-folder-draft-image . wl-draft-folder-icon) - (wl-folder-queue-image . wl-queue-folder-icon) - (wl-folder-trash-image . wl-trash-folder-icon))) + (wl-folder-draft-image . wl-draft-folder-icon) + (wl-folder-queue-image . wl-queue-folder-icon) + (wl-folder-trash-image . wl-trash-folder-icon))) (defun wl-folder-init-icons () (when (wl-e21-display-image-p) - (let ((load-path (cons wl-icon-directory load-path)) - (icons wl-folder-internal-icon-list) + (let ((icons wl-folder-internal-icon-list) icon name image) (while (setq icon (pop icons)) (unless (get (car icon) 'image) (setq name (symbol-value (cdr icon)) - image (find-image `((:type xpm :file ,name :ascent center)))) + image (wl-e21-find-image + `((:type xpm :file ,name :ascent center)))) (when image - (put (car icon) 'image (propertize name 'display image)))))))) + (put (car icon) 'image image))))))) (defun wl-plugged-init-icons () (let ((props (when (display-mouse-p) @@ -462,15 +484,14 @@ (if (wl-e21-display-image-p) (progn (unless wl-plugged-image - (let ((load-path (cons wl-icon-directory load-path))) - (setq wl-plugged-image (find-image + (setq wl-plugged-image (wl-e21-find-image + `((:type xpm + :file ,wl-plugged-icon + :ascent center))) + wl-unplugged-image (wl-e21-find-image `((:type xpm - :file ,wl-plugged-icon - :ascent center))) - wl-unplugged-image (find-image - `((:type xpm - :file ,wl-unplugged-icon - :ascent center)))))) + :file ,wl-unplugged-icon + :ascent center))))) (setq wl-modeline-plug-state-on (apply 'propertize wl-plug-state-indicator-on `(display ,wl-plugged-image ,@props)) @@ -493,15 +514,14 @@ (if (wl-e21-display-image-p) (progn (unless wl-biff-mail-image - (let ((load-path (cons wl-icon-directory load-path))) - (setq wl-biff-mail-image (find-image + (setq wl-biff-mail-image (wl-e21-find-image + `((:type xpm + :file ,wl-biff-mail-icon + :ascent center))) + wl-biff-nomail-image (wl-e21-find-image `((:type xpm - :file ,wl-biff-mail-icon - :ascent center))) - wl-biff-nomail-image (find-image - `((:type xpm - :file ,wl-biff-nomail-icon - :ascent center)))))) + :file ,wl-biff-nomail-icon + :ascent center))))) (setq wl-modeline-biff-state-on (apply 'propertize wl-biff-state-indicator-on `(display ,wl-biff-mail-image ,@props)) @@ -526,11 +546,18 @@ (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 "w" 'wl-draft) (define-key keymap [mouse-4] 'wl-message-wheel-down) (define-key keymap [mouse-5] 'wl-message-wheel-up) (define-key keymap [S-mouse-4] 'wl-message-wheel-down) (define-key keymap [S-mouse-5] 'wl-message-wheel-up) + ;; Meadow2 + (define-key keymap [mouse-wheel1] 'wl-message-wheel-dispatcher) + (define-key keymap [S-mouse-wheel1] 'wl-message-wheel-dispatcher) (set-keymap-parent wl-message-button-map keymap) (define-key wl-message-button-map [mouse-2] 'wl-message-button-dispatcher) @@ -538,9 +565,26 @@ (defalias 'wl-setup-message 'wl-e21-setup-message-toolbar) +;; Wheel handling for Meadow2 +(defun wl-message-wheel-dispatcher (event) + (interactive "e") + (if (< (nth 4 (nth 1 event)) 0) + (wl-message-wheel-up event) + (wl-message-wheel-down event))) + +(defun wl-summary-wheel-dispatcher (event) + (interactive "e") + (if (< (nth 4 (nth 1 event)) 0) + (if (memq 'shift (event-modifiers event)) + (wl-summary-down) + (wl-summary-next)) + (if (memq 'shift (event-modifiers event)) + (wl-summary-up) + (wl-summary-prev)))) + (defun wl-message-wheel-up (event) (interactive "e") - (if (string-match (regexp-quote wl-message-buffer-cache-name) + (if (string-match (regexp-quote wl-message-buffer-name) (regexp-quote (buffer-name))) (wl-message-next-page) (let ((cur-buf (current-buffer)) @@ -556,7 +600,7 @@ (defun wl-message-wheel-down (event) (interactive "e") - (if (string-match (regexp-quote wl-message-buffer-cache-name) + (if (string-match (regexp-quote wl-message-buffer-name) (regexp-quote (buffer-name))) (wl-message-prev-page) (let ((cur-buf (current-buffer)) @@ -576,8 +620,20 @@ '("Send Message" . wl-draft-send-and-exit)) (define-key keymap [menu-bar mail send-stay] '("Send, Keep Editing" . wl-draft-send)) + (define-key-after (lookup-key keymap [menu-bar mail]) + [mail-sep-send] '("--") + 'send-stay) (define-key keymap [menu-bar mail cancel] '("Kill Current Draft" . wl-draft-kill)) + (define-key-after (lookup-key keymap [menu-bar mail]) + [save] '("Save Draft and Exit" . wl-draft-save-and-exit) + 'cancel) + (define-key-after (lookup-key keymap [menu-bar mail]) + [mail-sep-exit] '("--") + 'save) + (define-key-after (lookup-key keymap [menu-bar mail]) + [preview] '("Preview Message" . wl-draft-preview-message) + 'mail-sep-exit) (define-key keymap [menu-bar mail yank] '("Cite Message" . wl-draft-yank-original)) (define-key keymap [menu-bar mail signature] @@ -592,7 +648,8 @@ See info under Wanderlust for full documentation. Special commands: -\\{wl-draft-mode-map}")) +\\{wl-draft-mode-map}" + (setq font-lock-defaults nil))) (defun wl-draft-key-setup () (define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original) @@ -609,23 +666,31 @@ Special commands: (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-c\C-a" 'wl-addrmgr) -;; (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save) +;;; (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-c\C-d" 'wl-draft-elide-region)) + (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 () (wl-mode-line-buffer-identification) -;; (local-set-key "\C-c\C-s" 'wl-draft-send);; override +;;; (local-set-key "\C-c\C-s" 'wl-draft-send) ; override (wl-e21-setup-draft-toolbar) (wl-draft-overload-menubar)) (defalias 'wl-defface 'defface) -(defun wl-read-event-char () +(defun wl-read-event-char (&optional prompt) "Get the next event." - (let ((event (read-event))) + (let ((event (read-event prompt))) (cons (and (numberp event) event) event))) +(put 'wl-modeline-biff-state-on 'risky-local-variable t) +(put 'wl-modeline-biff-state-off 'risky-local-variable t) +(put 'wl-modeline-plug-state-on 'risky-local-variable t) +(put 'wl-modeline-plug-state-off 'risky-local-variable t) + (require 'product) (product-provide (provide 'wl-e21) (require 'wl-version))