wl/wl-e21.el

   1 ;;; wl-e21.el -- Wanderlust modules for Emacs 21.
   2
   3 ;; Copyright 2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Katsumi Yamaoka <yamaoka@jpl.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
   9
  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)
  13 ;; any later version.
  14 ;;
  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.
  19 ;;
  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.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (eval-when-compile
  33   (require 'wl-folder)
  34   (require 'wl-summary)
  35   (require 'wl-draft)
  36   (require 'wl-message)
  37   (require 'wl-highlight)
  38   (defvar-maybe wl-draft-mode-map (make-sparse-keymap)))
  39
  40 (defvar wl-use-toolbar (and (display-graphic-p)
  41                             (image-type-available-p 'xpm)))
  42 (defvar wl-plugged-image nil)
  43 (defvar wl-unplugged-image nil)
  44
  45 (defvar wl-folder-toolbar
  46   '([wl-folder-jump-to-current-entity
  47      wl-folder-jump-to-current-entity t "Enter Current Folder"]
  48     [wl-folder-next-entity
  49      wl-folder-next-entity t "Next Folder"]
  50     [wl-folder-prev-entity
  51      wl-folder-prev-entity t "Previous Folder"]
  52     [wl-folder-check-current-entity
  53      wl-folder-check-current-entity t "Check Current Folder"]
  54     ;;[wl-draft
  55     ;; wl-draft t "Write a New Message"]
  56     [wl-folder-sync-current-entity
  57      wl-folder-sync-current-entity t "Sync Current Folder"]
  58     [wl-draft
  59      wl-draft t "Write a New Message"]
  60     [wl-folder-empty-trash
  61      wl-folder-empty-trash t "Empty Trash"]
  62     [wl-exit
  63      wl-exit t "Quit Wanderlust"]
  64     )
  65   "The Folder buffer toolbar.")
  66
  67 (defvar wl-summary-toolbar
  68   '([wl-summary-read
  69      wl-summary-read t "Read Messages"]
  70     [wl-summary-next
  71      wl-summary-next t "Next Message"]
  72     [wl-summary-prev
  73      wl-summary-prev t "Previous Message"]
  74     [wl-summary-jump-to-current-message
  75      wl-summary-jump-to-current-message t "Jump to Current Message"]
  76     [wl-summary-sync-force-update
  77      wl-summary-sync-force-update t "Sync Current Folder"]
  78     [wl-summary-delete
  79      wl-summary-delete t "Delete Current Message"]
  80     [wl-summary-mark-as-important
  81      wl-summary-mark-as-important t "Mark Current Message as Important"]
  82     [wl-draft
  83      wl-draft t "Write a New Message"]
  84     [wl-summary-reply
  85      wl-summary-reply t "Reply to Current Message" ]
  86     [wl-summary-reply-with-citation
  87      wl-summary-reply-with-citation t "Reply to Current Message with Citation"]
  88     [wl-summary-forward
  89      wl-summary-forward t "Forward Current Message"]
  90     [wl-summary-exit
  91      wl-summary-exit t "Exit Current Summary"]
  92     )
  93   "The Summary buffer toolbar.")
  94
  95 (defvar wl-message-toolbar
  96   '([wl-message-read
  97      wl-message-read t "Read Contents"]
  98     [wl-message-next-content
  99      wl-message-next-content t "Next Content"]
 100     [wl-message-prev-content
 101      wl-message-prev-content t "Previous Content"]
 102     [wl-message-quit
 103      wl-message-quit t "Back to Summary"]
 104     [wl-message-play-content
 105      wl-message-play-content t "Play Content"]
 106     [wl-message-extract-content
 107      wl-message-extract-content t "Extract Content"]
 108     )
 109   "The Message buffer toolbar.")
 110
 111 (defalias 'wl-draft-insert-signature 'insert-signature);; for draft toolbar.
 112
 113 (defvar wl-draft-toolbar
 114   '([wl-draft-send-from-toolbar
 115      wl-draft-send-from-toolbar t "Send Current Draft"]
 116     [wl-draft-yank-original
 117      wl-draft-yank-original t "Yank Displaying Message"]
 118     [wl-draft-insert-signature
 119      wl-draft-insert-signature t "Insert Signature"]
 120     [wl-draft-kill
 121      wl-draft-kill t "Kill Current Draft"]
 122     )
 123   "The Draft buffer toolbar.")
 124
 125 (defun wl-e21-setup-toolbar (bar)
 126   (let ((load-path (cons wl-icon-dir load-path))
 127         (success t)
 128         icon up down disabled name success)
 129     (while bar
 130       (setq icon (aref (car bar) 0)
 131             bar (cdr bar))
 132       (unless (boundp icon)
 133         (setq name (symbol-name icon)
 134               up (find-image `((:type xpm :file ,(concat name "-up.xpm")
 135                                       :ascent center)
 136                                (:type xbm :file ,(concat name "-up.xbm")
 137                                       :ascent center))))
 138         (if up
 139             (progn
 140               (setq down (find-image
 141                           `((:type xpm :file ,(concat name "-down.xpm")
 142                                    :ascent center)
 143                             (:type xbm :file ,(concat name "-down.xbm")
 144                                    :ascent center)))
 145                     disabled (find-image
 146                               `((:type xpm :file ,(concat name "-disabled.xpm")
 147                                        :ascent center)
 148                                 (:type xbm :file ,(concat name "-disabled.xbm")
 149                                        :ascent center))))
 150               (set icon (vector down up disabled disabled)))
 151           (setq bar nil
 152                 success nil))))
 153     success))
 154
 155 (defvar wl-e21-toolbar-configurations
 156   '((auto-resize-tool-bar        . t)
 157     (auto-raise-tool-bar-buttons . t)
 158     (tool-bar-button-margin      . 0)
 159     (tool-bar-button-relief      . 2)))
 160
 161 (defun wl-e21-make-toolbar-buttons (keymap defs)
 162   (let ((configs wl-e21-toolbar-configurations)
 163         config)
 164     (while (setq config (pop configs))
 165       (set (make-local-variable (car config)) (cdr config))))
 166   (modify-frame-parameters (selected-frame) '((tool-bar-lines . 1)))
 167   (let ((n (1- (length defs)))
 168         def)
 169     (while (>= n 0)
 170       (setq def (nth n defs)
 171             n (1- n))
 172       (define-key keymap (vector 'tool-bar (aref def 1))
 173         (list 'menu-item (aref def 3) (aref def 1)
 174               :enable (aref def 2)
 175               :image (symbol-value (aref def 0)))))))
 176
 177 (defun wl-e21-setup-folder-toolbar ()
 178   (and wl-use-toolbar
 179        (wl-e21-setup-toolbar wl-folder-toolbar)
 180        (wl-e21-make-toolbar-buttons wl-folder-mode-map wl-folder-toolbar)))
 181
 182 (defun wl-e21-setup-summary-toolbar ()
 183   (and wl-use-toolbar
 184        (wl-e21-setup-toolbar wl-summary-toolbar)
 185        (wl-e21-make-toolbar-buttons wl-summary-mode-map wl-summary-toolbar)))
 186
 187 (defun wl-e21-setup-message-toolbar ()
 188   (and wl-use-toolbar
 189        (wl-e21-setup-toolbar wl-message-toolbar)
 190        (wl-e21-make-toolbar-buttons (current-local-map) wl-message-toolbar)))
 191
 192 (defun wl-e21-setup-draft-toolbar ()
 193   (and wl-use-toolbar
 194        (wl-e21-setup-toolbar wl-draft-toolbar)
 195        (wl-e21-make-toolbar-buttons wl-draft-mode-map wl-draft-toolbar)))
 196
 197 (defun wl-e21-insert-image (image &optional string)
 198   (unless string
 199     (setq string " "))
 200   (let* ((from (point))
 201          (to (+ from (length string))))
 202     (if (stringp image)
 203         (progn
 204           (insert string)
 205           (let ((ovl (make-overlay from to)))
 206             (overlay-put ovl 'before-string image)
 207             (overlay-put ovl 'evaporate t)
 208             (add-text-properties from to
 209                                  '(invisible t intangible t
 210                                              rear-nonsticky t))))
 211       (insert-image image string))
 212     (put-text-property from to 'wl-e21-icon t)))
 213
 214 (defun wl-e21-make-icon-image (icon-string icon-file)
 215   (if wl-highlight-folder-with-icon
 216       (let ((load-path (cons wl-icon-dir load-path)))
 217         (cond ((let (case-fold-search)
 218                  ;; It may be a default value.
 219                  (string-match "\\.xpm$" icon-file))
 220                (find-image
 221                 `((:type xpm :file ,icon-file :ascent center)
 222                   (:type xbm
 223                          :file ,(concat
 224                                  (substring icon-file 0 (match-beginning 0))
 225                                  ".xbm")
 226                          :ascent center))))
 227               ((let ((case-fold-search t))
 228                  (string-match "\\.\\(x[bp]m\\|png\\|gif\\)$" icon-file))
 229                (find-image
 230                 `((:type ,(intern (downcase (match-string 1 icon-file)))
 231                          :file ,icon-file :ascent center))))))
 232     icon-string))
 233
 234 (defun wl-highlight-folder-current-line (&optional numbers)
 235   (interactive)
 236   (save-excursion
 237     (let ((fld-name (wl-folder-get-folder-name-by-id
 238                      (get-text-property (point) 'wl-folder-entity-id)))
 239           type num)
 240       (beginning-of-line)
 241       (when (and fld-name (looking-at "[ \t]+\\([^ \t]+\\)"))
 242         (goto-char (1- (match-beginning 1)))
 243         (let ((inhibit-read-only t))
 244           (if (get-text-property (point) 'wl-e21-icon)
 245               (delete-char 1)
 246             (forward-char 1))
 247           (cond
 248            ((string= fld-name wl-trash-folder);; set trash folder icon
 249             (setq num (nth 2 numbers));; number of messages
 250             (wl-e21-insert-image (get (if (or (not num) (zerop num))
 251                                           'wl-folder-trash-empty-image
 252                                         'wl-folder-trash-image)
 253                                       'image)))
 254            ((string= fld-name wl-draft-folder);; set draft folder icon
 255             (wl-e21-insert-image (get 'wl-folder-draft-image 'image)))
 256            ((string= fld-name wl-queue-folder)
 257             (wl-e21-insert-image (get 'wl-folder-queue-image 'image)))
 258            ((and (setq type (elmo-folder-get-type fld-name))
 259                  (or numbers;; XXX dirty...!!
 260                      (not (assoc fld-name wl-folder-group-alist))))
 261             ;; not group folder.
 262             (wl-e21-insert-image (get (intern (format "wl-folder-%s-image"
 263                                                       type))
 264                                       'image)))))))
 265     (let (fsymbol matched)
 266       (when (and numbers (nth 0 numbers) (nth 1 numbers))
 267         (setq matched t
 268               fsymbol
 269               (let ((unsync (nth 0 numbers))
 270                     (unread (nth 1 numbers)))
 271                 (cond ((and unsync (zerop unsync))
 272                        (if (and unread (zerop unread))
 273                            'wl-highlight-folder-zero-face
 274                          'wl-highlight-folder-unread-face))
 275                       ((and unsync
 276                             (>= unsync wl-folder-many-unsync-threshold))
 277                        'wl-highlight-folder-many-face)
 278                       (t
 279                        'wl-highlight-folder-few-face))))
 280         (let ((inhibit-read-only t))
 281           (put-text-property (line-beginning-position) (line-end-position)
 282                              'face fsymbol)))
 283       (let ((highlights '("opened" "closed"))
 284             highlight image)
 285         (while (setq highlight (pop highlights))
 286           (unless wl-highlight-group-folder-by-numbers
 287             (setq fsymbol (intern (format "wl-highlight-folder-%s-face"
 288                                           highlight))))
 289           (beginning-of-line)
 290           (when (looking-at (symbol-value
 291                              (intern (format "wl-highlight-folder-%s-regexp"
 292                                              highlight))))
 293             (let ((from (match-beginning 1))
 294                   (to (match-end 1))
 295                   (string (match-string-no-properties 1)))
 296               (setq image (intern (format "wl-folder-%s-image" highlight))
 297                     matched t
 298                     highlights nil)
 299               (unless (get image 'image)
 300                 (put image 'image
 301                      (wl-e21-make-icon-image
 302                       string
 303                       (symbol-value
 304                        (cdr (assq image wl-folder-toggle-icon-list))))))
 305               (let ((inhibit-read-only t))
 306                 (delete-region (goto-char from) to)
 307                 (wl-e21-insert-image (get image 'image) string)
 308                 (put-text-property (line-beginning-position)
 309                                    (line-end-position) 'face fsymbol))))))
 310       (unless matched
 311         (beginning-of-line)
 312         (let ((inhibit-read-only t))
 313           (put-text-property (point) (line-end-position) 'face
 314                              (if (looking-at (format "^[ ]*\\(%s\\|%s\\)"
 315                                                      wl-folder-unsubscribe-mark
 316                                                      wl-folder-removed-mark))
 317                                  'wl-highlight-folder-killed-face
 318                                'wl-highlight-folder-unknown-face))))
 319       (when wl-use-highlight-mouse-line
 320         (wl-highlight-folder-mouse-line)))))
 321
 322 (defun wl-highlight-plugged-current-line ()
 323   (interactive)
 324   (save-excursion
 325     (beginning-of-line)
 326     (when (looking-at "[ \t]*\\(\\[\\([^]]+\\)\\]\\)")
 327       (let ((inhibit-read-only t))
 328         (add-text-properties (match-beginning 1) (goto-char (match-end 1))
 329                              '(invisible t intangible t rear-nonsticky t))
 330         (when (get-text-property (point) 'wl-e21-icon)
 331           (delete-char 1))
 332         (wl-e21-insert-image
 333          (if (string= wl-plugged-plug-on (elmo-match-buffer 2))
 334              wl-plugged-image
 335            wl-unplugged-image))))))
 336
 337 (defun wl-plugged-set-folder-icon (folder string)
 338   (let ((istring (concat " " string))
 339         type)
 340     (cond ((string= folder wl-queue-folder)
 341            (put-text-property 0 1 'display
 342                               (get 'wl-folder-queue-image 'image) istring)
 343            istring)
 344           ((setq type (elmo-folder-get-type folder))
 345            (put-text-property 0 1 'display
 346                               (get (intern (format "wl-folder-%s-image" type))
 347                                    'image)
 348                               istring)
 349            istring)
 350           (t
 351            string))))
 352
 353 (defvar wl-folder-internal-icon-list
 354   ;; alist of (image . icon-file)
 355   '((wl-folder-nntp-image         . wl-nntp-folder-icon)
 356     (wl-folder-imap4-image        . wl-imap-folder-icon)
 357     (wl-folder-pop3-image         . wl-pop-folder-icon)
 358     (wl-folder-localdir-image     . wl-localdir-folder-icon)
 359     (wl-folder-localnews-image    . wl-localnews-folder-icon)
 360     (wl-folder-internal-image     . wl-internal-folder-icon)
 361     (wl-folder-multi-image        . wl-multi-folder-icon)
 362     (wl-folder-filter-image       . wl-filter-folder-icon)
 363     (wl-folder-archive-image      . wl-archive-folder-icon)
 364     (wl-folder-pipe-image         . wl-pipe-folder-icon)
 365     (wl-folder-maildir-image      . wl-maildir-folder-icon)
 366     (wl-folder-trash-empty-image  . wl-empty-trash-folder-icon)
 367     (wl-folder-draft-image        . wl-draft-folder-icon)
 368     (wl-folder-queue-image        . wl-queue-folder-icon)
 369     (wl-folder-trash-image        . wl-trash-folder-icon)))
 370
 371 (defvar wl-folder-toggle-icon-list
 372   '((wl-folder-opened-image       . wl-opened-group-folder-icon)
 373     (wl-folder-closed-image       . wl-closed-group-folder-icon)))
 374
 375 (defun wl-folder-init-icons ()
 376   (let ((load-path (cons wl-icon-dir load-path))
 377         (icons wl-folder-internal-icon-list)
 378         icon name case-fold-search)
 379     (while (setq icon (pop icons))
 380       (unless (get (car icon) 'image)
 381         (setq name (symbol-value (cdr icon)))
 382         (put (car icon) 'image
 383              (cond ((let (case-fold-search)
 384                       ;; It may be a default value.
 385                       (string-match "\\.xpm$" name))
 386                     (find-image
 387                      `((:type xpm :file ,name :ascent center)
 388                        (:type xbm
 389                               :file ,(concat
 390                                       (substring name 0 (match-beginning 0))
 391                                       ".xbm")
 392                               :ascent center))))
 393                    ((let ((case-fold-search t))
 394                       (string-match "\\.\\(x[bp]m\\|png\\|gif\\)$" name))
 395                     (find-image
 396                      `((:type ,(intern (downcase (match-string 1 name)))
 397                               :file ,name :ascent center))))))))))
 398
 399 (defun wl-plugged-init-icons ()
 400   (unless wl-plugged-image
 401     (setq wl-plug-state-indicator-on (concat "[" wl-plugged-plug-on "]")
 402           wl-plugged-image (wl-e21-make-icon-image
 403                             wl-plug-state-indicator-on
 404                             wl-plugged-icon)))
 405   (unless wl-unplugged-image
 406     (setq wl-plug-state-indicator-off (concat "[" wl-plugged-plug-off "]")
 407           wl-unplugged-image (wl-e21-make-icon-image
 408                               wl-plug-state-indicator-off
 409                               wl-unplugged-icon)))
 410   (let ((props (list 'local-map (purecopy (make-mode-line-mouse2-map
 411                                            #'wl-toggle-plugged))
 412                      'help-echo "mouse-2 toggles plugged status")))
 413     (add-text-properties 0 (length wl-plug-state-indicator-on)
 414                          (nconc props (unless (stringp wl-plugged-image)
 415                                         (list 'display wl-plugged-image)))
 416                          wl-plug-state-indicator-on)
 417     (add-text-properties 0 (length wl-plug-state-indicator-off)
 418                          (nconc props (unless (stringp wl-unplugged-image)
 419                                         (list 'display wl-unplugged-image)))
 420                          wl-plug-state-indicator-off)))
 421
 422 (defun wl-make-date-string ()
 423   (format-time-string "%a, %d %b %Y %T %z"))
 424
 425 (defalias 'wl-e21-setup-folder 'wl-e21-setup-folder-toolbar)
 426
 427 (defalias 'wl-e21-setup-summary 'wl-e21-setup-summary-toolbar)
 428
 429 (defun wl-message-overload-functions ()
 430   (wl-e21-setup-message-toolbar)
 431   (let ((keymap (current-local-map)))
 432     (define-key keymap "l" 'wl-message-toggle-disp-summary)
 433     (define-key keymap [mouse-2] 'wl-message-refer-article-or-url)
 434     (define-key keymap [mouse-4] 'wl-message-wheel-down)
 435     (define-key keymap [mouse-5] 'wl-message-wheel-up)
 436     (define-key keymap [S-mouse-4] 'wl-message-wheel-down)
 437     (define-key keymap [S-mouse-5] 'wl-message-wheel-up)
 438     (set-keymap-parent wl-message-button-map keymap))
 439   (define-key wl-message-button-map [mouse-2] 'wl-message-button-dispatcher))
 440
 441 (defun wl-message-wheel-up (event)
 442   (interactive "e")
 443   (if (string-match wl-message-buf-name (buffer-name))
 444       (wl-message-next-page)
 445     (let ((cur-buf (current-buffer))
 446           proceed)
 447       (save-selected-window
 448         (select-window (posn-window (event-start event)))
 449         (set-buffer cur-buf)
 450         (setq proceed (wl-message-next-page)))
 451       (if proceed
 452           (if (memq 'shift (event-modifiers event))
 453               (wl-summary-down t)
 454             (wl-summary-next t))))))
 455
 456 (defun wl-message-wheel-down (event)
 457   (interactive "e")
 458   (if (string-match wl-message-buf-name (buffer-name))
 459       (wl-message-prev-page)
 460     (let ((cur-buf (current-buffer))
 461           proceed)
 462       (save-selected-window
 463         (select-window (posn-window (event-start event)))
 464         (set-buffer cur-buf)
 465         (setq proceed (wl-message-prev-page)))
 466       (if proceed
 467           (if (memq 'shift (event-modifiers event))
 468               (wl-summary-up t)
 469             (wl-summary-prev t))))))
 470
 471 (defun wl-draft-overload-menubar ()
 472   (let ((keymap (current-local-map)))
 473     (define-key keymap [menu-bar mail send]
 474       '("Send Message" . wl-draft-send-and-exit))
 475     (define-key keymap [menu-bar mail send-stay]
 476       '("Send, Keep Editing" . wl-draft-send))
 477     (define-key keymap [menu-bar mail cancel]
 478       '("Kill Current Draft" . wl-draft-kill))
 479     (define-key keymap [menu-bar mail yank]
 480       '("Cite Message" . wl-draft-yank-original))
 481     (define-key keymap [menu-bar mail signature]
 482       '("Insert Signature" . insert-signature))
 483     (define-key keymap [menu-bar headers fcc]
 484       '("FCC" . wl-draft-fcc))))
 485
 486 (defun wl-draft-mode-setup ()
 487   (require 'derived)
 488   (define-derived-mode wl-draft-mode mail-mode "Draft"
 489     "draft mode for Wanderlust derived from mail mode.
 490 See info under Wanderlust for full documentation.
 491
 492 Special commands:
 493 \\{wl-draft-mode-map}"))
 494
 495 (defun wl-draft-key-setup ()
 496   (define-key wl-draft-mode-map "\C-c\C-y" 'wl-draft-yank-original)
 497   (define-key wl-draft-mode-map "\C-c\C-s" 'wl-draft-send)
 498   (define-key wl-draft-mode-map "\C-c\C-a" 'wl-draft-insert-x-face-field)
 499   (define-key wl-draft-mode-map "\C-c\C-c" 'wl-draft-send-and-exit)
 500   (define-key wl-draft-mode-map "\C-c\C-z" 'wl-draft-save-and-exit)
 501   (define-key wl-draft-mode-map "\C-c\C-k" 'wl-draft-kill)
 502   (define-key wl-draft-mode-map "\C-l" 'wl-draft-highlight-and-recenter)
 503   (define-key wl-draft-mode-map "\C-i" 'wl-complete-field-body-or-tab)
 504   (define-key wl-draft-mode-map "\C-c\C-r" 'wl-draft-caesar-region)
 505   (define-key wl-draft-mode-map "\M-t" 'wl-toggle-plugged)
 506   (define-key wl-draft-mode-map "\C-c\C-o" 'wl-jump-to-draft-buffer)
 507   (define-key wl-draft-mode-map "\C-c\C-e" 'wl-draft-config-exec)
 508   (define-key wl-draft-mode-map "\C-c\C-j" 'wl-template-select)
 509   (define-key wl-draft-mode-map "\C-c\C-p" 'wl-draft-preview-message)
 510   (define-key wl-draft-mode-map "\C-x\C-s" 'wl-draft-save)
 511   (define-key wl-draft-mode-map "\C-xk"    'wl-draft-mimic-kill-buffer))
 512
 513 (defun wl-draft-overload-functions ()
 514   (setq mode-line-buffer-identification
 515         (wl-mode-line-buffer-identification
 516          (if wl-show-plug-status-on-modeline
 517              '("" wl-plug-state-indicator "Wanderlust: %12b")
 518            '("Wanderlust: %12b"))))
 519   (local-set-key "\C-c\C-s" 'wl-draft-send);; override
 520   (wl-e21-setup-draft-toolbar)
 521   (wl-draft-overload-menubar))
 522
 523 (defalias 'wl-defface 'defface)
 524
 525 (provide 'wl-e21)
 526
 527 ;;; wl-e21.el ends here