X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-e21.el;h=7767bca14b7bdebcbf2a4679bc32d39b4256f81d;hb=d435474a02bfed44eea9397d4f4673f541a8af84;hp=8d2d335d69bbdd4467d82f4ab25e0a1d95019f4e;hpb=fda32c1bfee5b97e5813e88e2d0ff157fa372b6b;p=elisp%2Fwanderlust.git diff --git a/wl/wl-e21.el b/wl/wl-e21.el index 8d2d335..7767bca 100644 --- a/wl/wl-e21.el +++ b/wl/wl-e21.el @@ -1,7 +1,7 @@ -;;; wl-e21.el -- Wanderlust modules for Emacs 21. +;;; wl-e21.el --- Wanderlust modules for Emacs 21. -;; Copyright 2000 Katsumi Yamaoka -;; Yuuichi Teranishi +;; Copyright (C) 2000,2001 Katsumi Yamaoka +;; Copyright (C) 2000,2001 Yuuichi Teranishi ;; Author: Katsumi Yamaoka ;; Keywords: mail, net news @@ -33,7 +33,7 @@ ;;(let (image icon from to overlay) ;; ;; The function `find-image' will look for an image first on `load-path' ;; ;; and then in `data-directory'. -;; (let ((load-path (cons wl-icon-dir load-path))) +;; (let ((load-path (cons wl-icon-directory load-path))) ;; (setq image (find-image (list (list :type 'xpm :file wl-nntp-folder-icon ;; :ascent 'center))))) ;; ;; `propertize' is a convenient function in such a case. @@ -54,10 +54,15 @@ ;; (overlay-put overlay 'wl-e21-icon t) ;; ;; Make it to be removable. ;; (overlay-put overlay 'evaporate t)) +;; +;; Note that a port of Emacs to some platforms (e.g. MS-Windoze) does +;; not yet support images. It is a pity that neither icons nor tool- +;; bars will not be displayed in such systems. ;;; Code: ;; +(require 'elmo) (eval-when-compile (require 'wl-folder) (require 'wl-summary) @@ -75,6 +80,8 @@ (add-hook 'wl-summary-mode-hook 'wl-setup-summary) +(add-hook 'wl-message-display-internal-hook 'wl-setup-message) + (defvar wl-use-toolbar (image-type-available-p 'xpm)) (defvar wl-plugged-image nil) (defvar wl-unplugged-image nil) @@ -161,30 +168,37 @@ ) "The Draft buffer toolbar.") +(eval-when-compile + (defmacro wl-e21-display-image-p () + '(and (display-images-p) + (image-type-available-p 'xpm)))) + (defun wl-e21-setup-toolbar (bar) - (let ((load-path (cons wl-icon-dir load-path)) - (props '(:type xpm :ascent center - :color-symbols (("backgroundToolBarColor" . "None")) - :file)) - (success t) - icon up down disabled name success) - (while bar - (setq icon (aref (pop bar) 0)) - (unless (boundp icon) - (setq name (symbol-name icon) - up (find-image `((,@props ,(concat name "-up.xpm"))))) - (if up - (progn - (setq down (find-image `((,@props ,(concat name "-down.xpm")))) - disabled (find-image `((,@props - ,(concat name "-disabled.xpm"))))) - (set icon (vector down up disabled disabled))) - (setq bar nil - success nil)))) - success)) + (when (and wl-use-toolbar + (wl-e21-display-image-p)) + (let ((load-path (cons wl-icon-directory load-path)) + (props '(:type xpm :ascent center + :color-symbols (("backgroundToolBarColor" . "None")) + :file)) + (success t) + icon up down disabled name) + (while bar + (setq icon (aref (pop bar) 0)) + (unless (boundp icon) + (setq name (symbol-name icon) + up (find-image `((,@props ,(concat name "-up.xpm"))))) + (if up + (progn + (setq down (find-image `((,@props ,(concat name "-down.xpm")))) + disabled (find-image + `((,@props ,(concat name "-disabled.xpm"))))) + (set icon (vector down up disabled disabled))) + (setq bar nil + success nil)))) + success))) (defvar wl-e21-toolbar-configurations - '((auto-resize-tool-bar . t) + '((auto-resize-tool-bars . t) (auto-raise-tool-bar-buttons . t) (tool-bar-button-margin . 0) (tool-bar-button-relief . 2))) @@ -211,29 +225,21 @@ :image (symbol-value (aref def 0))))))) (defun wl-e21-setup-folder-toolbar () - (and wl-use-toolbar - (display-graphic-p) - (wl-e21-setup-toolbar wl-folder-toolbar) - (wl-e21-make-toolbar-buttons wl-folder-mode-map wl-folder-toolbar))) + (when (wl-e21-setup-toolbar wl-folder-toolbar) + (wl-e21-make-toolbar-buttons wl-folder-mode-map wl-folder-toolbar))) (defun wl-e21-setup-summary-toolbar () - (and wl-use-toolbar - (display-graphic-p) - (wl-e21-setup-toolbar wl-summary-toolbar) - (wl-e21-make-toolbar-buttons wl-summary-mode-map wl-summary-toolbar))) + (when (wl-e21-setup-toolbar wl-summary-toolbar) + (wl-e21-make-toolbar-buttons wl-summary-mode-map wl-summary-toolbar))) (eval-when-compile - (defsubst wl-e21-setup-message-toolbar (keymap) - (and wl-use-toolbar - (display-graphic-p) - (wl-e21-setup-toolbar wl-message-toolbar) - (wl-e21-make-toolbar-buttons keymap wl-message-toolbar))) - (defsubst wl-e21-setup-draft-toolbar () - (and wl-use-toolbar - (display-graphic-p) - (wl-e21-setup-toolbar wl-draft-toolbar) - (wl-e21-make-toolbar-buttons wl-draft-mode-map wl-draft-toolbar)))) + (when (wl-e21-setup-toolbar wl-draft-toolbar) + (wl-e21-make-toolbar-buttons wl-draft-mode-map wl-draft-toolbar)))) + +(defun wl-e21-setup-message-toolbar () + (when (wl-e21-setup-toolbar wl-message-toolbar) + (wl-e21-make-toolbar-buttons (current-local-map) wl-message-toolbar))) (defvar wl-folder-toggle-icon-list '((wl-folder-opened-image . wl-opened-group-folder-icon) @@ -241,7 +247,7 @@ (eval-when-compile (defsubst wl-e21-highlight-folder-group-line (start end icon numbers) - (when (display-graphic-p) + (when (wl-e21-display-image-p) (let (overlay) (let ((overlays (overlays-in start end))) (while (and (setq overlay (pop overlays)) @@ -254,7 +260,7 @@ (unless image (let ((name (symbol-value (cdr (assq icon wl-folder-toggle-icon-list)))) - (load-path (cons wl-icon-dir load-path))) + (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 @@ -274,7 +280,7 @@ (let ((inhibit-read-only t)) (if (and wl-highlight-folder-by-numbers numbers (nth 0 numbers) (nth 1 numbers) - (re-search-forward "[0-9-]+/[0-9-]+/[0-9-]+" + (re-search-forward "[-[:digit:]]+/[-[:digit:]]+/[-[:digit:]]+" (line-end-position) t)) (let* ((unsync (nth 0 numbers)) (unread (nth 1 numbers)) @@ -326,11 +332,11 @@ (;; 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\n ]+\\)")) + (looking-at "[[:blank:]]+\\([^[:blank:]\n]+\\)")) (setq start (match-beginning 1) end (match-end 1)) (let (image) - (when (display-graphic-p) + (when (wl-e21-display-image-p) (let (overlay) (let ((overlays (overlays-in start end))) (while (and (setq overlay (pop overlays)) @@ -340,6 +346,8 @@ (overlay-put overlay 'wl-e21-icon t) (overlay-put overlay 'evaporate t)) (let (type) + (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 @@ -352,7 +360,7 @@ ((string= fld-name wl-queue-folder);; queue folder (get 'wl-folder-queue-image 'image)) (;; and one of many other folders - (setq type (elmo-folder-get-type fld-name)) + (setq type (elmo-folder-type fld-name)) (get (intern (format "wl-folder-%s-image" type)) 'image))))) (overlay-put overlay 'before-string image))) @@ -367,7 +375,7 @@ (when (display-color-p) (wl-e21-highlight-folder-by-numbers start end - (if (looking-at (format "^[\t ]*\\(%s\\|%s\\)" + (if (looking-at (format "^[[:blank:]]*\\(?:%s\\|%s\\)" wl-folder-unsubscribe-mark wl-folder-removed-mark)) 'wl-highlight-folder-killed-face @@ -376,10 +384,10 @@ (defun wl-highlight-plugged-current-line () (interactive) - (when (display-graphic-p) + (when (wl-e21-display-image-p) (save-excursion (beginning-of-line) - (when (looking-at "[\t ]*\\(\\[\\([^]]+\\)\\]\\)") + (when (looking-at "[[:blank:]]*\\(\\[\\([^]]+\\)\\]\\)") (let* ((start (match-beginning 1)) (end (match-end 1)) (status (match-string-no-properties 2)) @@ -400,17 +408,15 @@ (overlay-put overlay 'invisible t)))))))) (defun wl-plugged-set-folder-icon (folder string) - (if (display-graphic-p) + (if (wl-e21-display-image-p) (let (type) (cond ((string= folder wl-queue-folder) - (concat (propertize " " 'display - (get 'wl-folder-queue-image 'image)) + (concat (get 'wl-folder-queue-image 'image) string)) - ((setq type (elmo-folder-get-type folder)) - (concat (propertize " " 'display - (get (intern (format "wl-folder-%s-image" - type)) - 'image)) + ((setq type (elmo-folder-type folder)) + (concat (get (intern (format "wl-folder-%s-image" + type)) + 'image) string)) (t string))) @@ -429,102 +435,113 @@ (wl-folder-archive-image . wl-archive-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-shimbun-image . wl-shimbun-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))) (defun wl-folder-init-icons () - (let ((load-path (cons wl-icon-dir load-path)) - (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)))) - (when image - (put (car icon) 'image (propertize name 'display image))))))) + (when (wl-e21-display-image-p) + (let ((load-path (cons wl-icon-directory load-path)) + (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)))) + (when image + (put (car icon) 'image (propertize name 'display image)))))))) (defun wl-plugged-init-icons () - (unless wl-plugged-image - (let ((load-path (cons wl-icon-dir load-path))) - (setq wl-plugged-image (find-image `((:type xpm - :file ,wl-plugged-icon - :ascent center))) - wl-unplugged-image (find-image `((:type xpm - :file ,wl-unplugged-icon - :ascent center)))))) - (if (display-mouse-p) - (let ((props (list 'local-map (purecopy (make-mode-line-mouse2-map - #'wl-toggle-plugged)) - 'help-echo "mouse-2 toggles plugged status"))) - (if (display-graphic-p) - (setq wl-modeline-plug-state-on - (apply 'propertize wl-plug-state-indicator-on - `(display ,wl-plugged-image ,@props)) - wl-modeline-plug-state-off - (apply 'propertize wl-plug-state-indicator-off - `(display ,wl-unplugged-image ,@props))) + (let ((props (when (display-mouse-p) + (list 'local-map (purecopy (make-mode-line-mouse-map + 'mouse-2 #'wl-toggle-plugged)) + 'help-echo "mouse-2 toggles plugged status")))) + (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 + `((:type xpm + :file ,wl-plugged-icon + :ascent center))) + wl-unplugged-image (find-image + `((:type xpm + :file ,wl-unplugged-icon + :ascent center)))))) + (setq wl-modeline-plug-state-on + (apply 'propertize wl-plug-state-indicator-on + `(display ,wl-plugged-image ,@props)) + wl-modeline-plug-state-off + (apply 'propertize wl-plug-state-indicator-off + `(display ,wl-unplugged-image ,@props)))) + (if props (setq wl-modeline-plug-state-on (apply 'propertize wl-plug-state-indicator-on props) wl-modeline-plug-state-off - (apply 'propertize wl-plug-state-indicator-off props)))) - (setq wl-modeline-plug-state-on wl-plug-state-indicator-on - wl-modeline-plug-state-off wl-plug-state-indicator-off))) + (apply 'propertize wl-plug-state-indicator-off props)) + (setq wl-modeline-plug-state-on wl-plug-state-indicator-on + wl-modeline-plug-state-off wl-plug-state-indicator-off))))) (defun wl-biff-init-icons () - (unless wl-biff-mail-image - (let ((load-path (cons wl-icon-dir load-path))) - (setq wl-biff-mail-image (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)))))) - (if (display-mouse-p) - (let ((props (list 'local-map (purecopy (make-mode-line-mouse2-map - (lambda nil - (call-interactively - 'wl-biff-check-folders)))) - 'help-echo "mouse-2 checks new mails"))) - (if (display-graphic-p) - (setq wl-modeline-biff-state-on - (apply 'propertize wl-biff-state-indicator-on - `(display ,wl-biff-mail-image ,@props)) - wl-modeline-biff-state-off - (apply 'propertize wl-biff-state-indicator-off - `(display ,wl-biff-nomail-image ,@props))) + (let ((props (when (display-mouse-p) + (list 'local-map (purecopy (make-mode-line-mouse-map + 'mouse-2 #'wl-biff-check-folders)) + 'help-echo "mouse-2 checks new mails")))) + (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 + `((:type xpm + :file ,wl-biff-mail-icon + :ascent center))) + wl-biff-nomail-image (find-image + `((:type xpm + :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)) + wl-modeline-biff-state-off + (apply 'propertize wl-biff-state-indicator-off + `(display ,wl-biff-nomail-image ,@props)))) + (if props (setq wl-modeline-biff-state-on (apply 'propertize wl-biff-state-indicator-on props) wl-modeline-biff-state-off - (apply 'propertize wl-biff-state-indicator-off props)))) - (setq wl-modeline-biff-state-on wl-biff-state-indicator-on - wl-modeline-biff-state-off wl-biff-state-indicator-off))) + (apply 'propertize wl-biff-state-indicator-off props)) + (setq wl-modeline-biff-state-on wl-biff-state-indicator-on + wl-modeline-biff-state-off wl-biff-state-indicator-off))))) (defun wl-make-date-string () - (format-time-string "%a, %d %b %Y %T %z")) + (let ((system-time-locale "C")) + (format-time-string "%a, %d %b %Y %T %z"))) (defalias 'wl-setup-folder 'wl-e21-setup-folder-toolbar) (defalias 'wl-setup-summary 'wl-e21-setup-summary-toolbar) -(defun wl-message-overload-functions () - (let ((keymap (current-local-map))) - (when keymap - (wl-e21-setup-message-toolbar keymap) - (define-key keymap "l" 'wl-message-toggle-disp-summary) - (define-key keymap [mouse-2] 'wl-message-refer-article-or-url) - (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) - (set-keymap-parent wl-message-button-map keymap) - (define-key wl-message-button-map - [mouse-2] 'wl-message-button-dispatcher)))) +(defun wl-message-define-keymap () + (let ((keymap (make-sparse-keymap))) + (define-key keymap "l" 'wl-message-toggle-disp-summary) + (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) + (set-keymap-parent wl-message-button-map keymap) + (define-key wl-message-button-map + [mouse-2] 'wl-message-button-dispatcher) + keymap)) + +(defalias 'wl-setup-message 'wl-e21-setup-message-toolbar) (defun wl-message-wheel-up (event) (interactive "e") - (if (string-match wl-message-buf-name (buffer-name)) + (if (string-match (regexp-quote wl-message-buffer-cache-name) + (regexp-quote (buffer-name))) (wl-message-next-page) (let ((cur-buf (current-buffer)) proceed) @@ -539,7 +556,8 @@ (defun wl-message-wheel-down (event) (interactive "e") - (if (string-match wl-message-buf-name (buffer-name)) + (if (string-match (regexp-quote wl-message-buffer-cache-name) + (regexp-quote (buffer-name))) (wl-message-prev-page) (let ((cur-buf (current-buffer)) proceed) @@ -565,7 +583,7 @@ (define-key keymap [menu-bar mail signature] '("Insert Signature" . insert-signature)) (define-key keymap [menu-bar headers fcc] - '("FCC" . wl-draft-fcc)))) + '("Fcc" . wl-draft-fcc)))) (defun wl-draft-mode-setup () (require 'derived) @@ -579,7 +597,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) @@ -591,17 +608,24 @@ 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-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-xk" 'wl-draft-mimic-kill-buffer) + (define-key wl-draft-mode-map "\C-c\C-d" 'wl-draft-elide-region)) (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 () + "Get the next event." + (let ((event (read-event))) + (cons (and (numberp event) event) event))) + (require 'product) (product-provide (provide 'wl-e21) (require 'wl-version))