X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-xmas.el;h=baa55e2407c00b5e41c2fe1db2a0796416762526;hb=611bdeb2f343b37fae32a9c8cacadc9d35c793c4;hp=2eddb5786cbd504a0bcc08cef25348dcbed20402;hpb=10a95fa561ec82f555499e359e703a69eaecbad5;p=elisp%2Fwanderlust.git diff --git a/wl/wl-xmas.el b/wl/wl-xmas.el index 2eddb57..baa55e2 100644 --- a/wl/wl-xmas.el +++ b/wl/wl-xmas.el @@ -1,10 +1,11 @@ -;;; wl-xmas.el -- Wanderlust modules for XEmacsen. +;;; wl-xmas.el --- Wanderlust modules for XEmacsen. -;; Copyright 1998,1999,2000 Yuuichi Teranishi -;; Copyright 2000 Katsumi Yamaoka +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Yuuichi Teranishi +;; Copyright (C) 2000, 2001, 2002, 2003 Katsumi Yamaoka -;; Author: Yuuichi Teranishi , -;; Katsumi Yamaoka +;; Author: Yuuichi Teranishi +;; Katsumi Yamaoka ;; Keywords: mail, net news ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen). @@ -45,11 +46,11 @@ (add-hook 'wl-init-hook 'wl-biff-init-icons) (add-hook 'wl-init-hook 'wl-plugged-init-icons) -;; (add-hook 'wl-make-plugged-hook 'wl-biff-init-icons) -;; (add-hook 'wl-make-plugged-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) @@ -65,12 +66,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 @@ -89,12 +90,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 @@ -133,11 +134,13 @@ 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-toolbar (bar) - (let ((dir wl-icon-dir) + (let ((dir wl-icon-directory) icon up down disabled name) (when dir (while bar @@ -162,7 +165,7 @@ (when wl-highlight-folder-with-icon (set-glyph-image glyph (vector 'xpm :file (expand-file-name - icon-file wl-icon-dir)) + icon-file wl-icon-directory)) locale tag-set 'prepend)) glyph)) @@ -179,18 +182,18 @@ (set-specifier (symbol-value wl-use-toolbar) (cons (current-buffer) wl-summary-toolbar)))) - (defsubst wl-xmas-setup-message-toolbar () - (and wl-use-toolbar - (wl-xmas-setup-toolbar wl-message-toolbar) - (set-specifier (symbol-value wl-use-toolbar) - (cons (current-buffer) wl-message-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 + (wl-xmas-setup-toolbar wl-message-toolbar) + (set-specifier (symbol-value wl-use-toolbar) + (cons (current-buffer) wl-message-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))) @@ -199,13 +202,13 @@ (defsubst wl-xmas-highlight-folder-group-line (glyph text-face numbers) (let ((start (match-beginning 1)) (end (match-end 1))) - (let (extent) - (while (and (setq extent (extent-at start nil nil extent 'at)) - (not (and (eq start (extent-start-position extent)) - (eq end (extent-end-position extent)) - (extent-end-glyph extent))))) - (unless extent - (setq extent (make-extent start end))) + (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 @@ -250,12 +253,14 @@ (let (fld-name) (cond (;; opened folder group - (looking-at wl-highlight-folder-opened-regexp) + (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 - (looking-at wl-highlight-folder-closed-regexp) + (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)) @@ -264,13 +269,13 @@ (get-text-property (point) 'wl-folder-entity-id))) (looking-at "[ \t]+\\([^ \t]+\\)")) (let ((start (match-beginning 1))) - (let (extent) - (while (and (setq extent (extent-at start nil nil extent 'at)) - (not (and (eq start (extent-start-position extent)) - (eq start (extent-end-position extent)) - (extent-begin-glyph extent))))) - (unless extent - (setq extent (make-extent start start))) + (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 @@ -286,13 +291,15 @@ ((string= fld-name wl-queue-folder);; queue folder (get 'wl-folder-queue-glyph 'glyph)) (;; and one of many other folders - (setq type (elmo-folder-get-type fld-name)) + (setq type (or (elmo-folder-type fld-name) + (elmo-folder-type-internal + (elmo-make-folder 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\\)" + (if (looking-at (format "^[ \t]*\\(?:%s\\|%s\\)" wl-folder-unsubscribe-mark wl-folder-removed-mark)) 'wl-highlight-folder-killed-face @@ -352,7 +359,7 @@ (put-text-property 0 len 'begin-glyph (get 'wl-folder-queue-glyph 'glyph) string) - (if (setq type (elmo-folder-get-type folder)) + (if (setq type (elmo-folder-type folder)) (put-text-property 0 len 'begin-glyph (get (intern (format "wl-folder-%s-glyph" type)) @@ -362,21 +369,25 @@ (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))) + '((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-search-glyph . wl-search-folder-icon) + (wl-folder-shimbun-glyph . wl-shimbun-folder-icon) + (wl-folder-file-glyph . wl-file-folder-icon) + (wl-folder-access-glyph . wl-access-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) @@ -438,43 +449,55 @@ (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) - (set-keymap-parent wl-message-button-map (current-local-map)) - (define-key wl-message-button-map 'button2 - 'wl-message-button-dispatcher)) +(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 "w" 'wl-draft) + (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))) - (when proceed - (if (memq 'shift (event-modifiers event)) - (wl-summary-down t) - (wl-summary-next t))))) + (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)))))) (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))) - (when proceed - (if (memq 'shift (event-modifiers event)) - (wl-summary-up t) - (wl-summary-prev t))))) + (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)))))) (defun wl-draft-overload-menubar () (when (featurep 'menubar) @@ -483,7 +506,14 @@ (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")))) + (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) @@ -497,7 +527,6 @@ Special commands: (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) @@ -509,17 +538,35 @@ Special commands: (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 () (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-xmas-setup-draft-toolbar) (wl-draft-overload-menubar)) (defalias 'wl-defface 'defface) +(defun wl-read-event-char (&optional prompt) + "Get the next event." + (let ((event (next-command-event nil prompt))) + (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))