1 ;;; wl-addrmgr.el --- Address manager for Wanderlust.
3 ;; Copyright (C) 2001 Kitamoto Tsuyoshi <tsuyoshi.kitamoto@city.sapporo.jp>
4 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Author: Kitamoto Tsuyoshi <tsuyoshi.kitamoto@city.sapporo.jp>
7 ;; Yuuichi Teranishi <teranisi@gohome.org>
8 ;; Keywords: mail, net news
10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
12 ;; This program is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; This program is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; Edit To:, Cc:, Bcc: fields interactively from E-Mail address list
30 ;; on ~/.address file.
39 (defgroup wl-addrmgr nil
40 "Wanderlust Address manager."
44 (defcustom wl-addrmgr-buffer-lines 10
45 "*Buffer lines for ADDRMGR buffer for draft."
49 (defcustom wl-addrmgr-default-sort-key 'realname
50 "Default element for sort."
51 :type '(choice '(address realname petname none))
54 (defcustom wl-addrmgr-default-sort-order 'ascending
55 "Default element for sort."
56 :type '(choice '(ascending descending))
59 (defcustom wl-addrmgr-realname-width 17
64 (defcustom wl-addrmgr-petname-width 10
69 (defcustom wl-addrmgr-line-width 78
70 "Width for each line."
74 (defcustom wl-addrmgr-realname-face 'wl-highlight-summary-normal-face
79 (defcustom wl-addrmgr-petname-face 'wl-highlight-summary-unread-face
84 (defcustom wl-addrmgr-address-face 'wl-highlight-summary-new-face
89 (defcustom wl-addrmgr-default-method 'local
90 "Default access method for address entries."
94 (defvar wl-addrmgr-buffer-name "Address")
95 (defvar wl-addrmgr-mode-map nil)
96 (defvar wl-addrmgr-method-list '(local))
98 ;; buffer local variable.
99 (defvar wl-addrmgr-draft-buffer nil)
100 (defvar wl-addrmgr-unknown-list nil)
101 (defvar wl-addrmgr-sort-key nil)
102 (defvar wl-addrmgr-sort-order nil)
103 (defvar wl-addrmgr-method nil)
104 (defvar wl-addrmgr-list nil)
105 (defvar wl-addrmgr-method-name nil)
107 (make-variable-buffer-local 'wl-addrmgr-draft-buffer)
108 (make-variable-buffer-local 'wl-addrmgr-unknown-list)
109 (make-variable-buffer-local 'wl-addrmgr-sort-key)
110 (make-variable-buffer-local 'wl-addrmgr-sort-order)
111 (make-variable-buffer-local 'wl-addrmgr-method)
112 (make-variable-buffer-local 'wl-addrmgr-list)
113 (make-variable-buffer-local 'wl-addrmgr-method-name)
117 (if wl-addrmgr-mode-map
119 (setq wl-addrmgr-mode-map (make-sparse-keymap))
120 (define-key wl-addrmgr-mode-map "<" 'wl-addrmgr-goto-top)
121 (define-key wl-addrmgr-mode-map ">" 'wl-addrmgr-goto-bottom)
122 (define-key wl-addrmgr-mode-map "t" 'wl-addrmgr-mark-set-to)
123 (define-key wl-addrmgr-mode-map "b" 'wl-addrmgr-mark-set-bcc)
124 (define-key wl-addrmgr-mode-map "c" 'wl-addrmgr-mark-set-cc)
125 (define-key wl-addrmgr-mode-map "u" 'wl-addrmgr-unmark)
126 (define-key wl-addrmgr-mode-map "x" 'wl-addrmgr-apply)
128 (define-key wl-addrmgr-mode-map "\C-c\C-c" 'wl-addrmgr-apply)
130 (define-key wl-addrmgr-mode-map "n" 'wl-addrmgr-next)
131 (define-key wl-addrmgr-mode-map "j" 'wl-addrmgr-next)
132 (define-key wl-addrmgr-mode-map "k" 'wl-addrmgr-prev)
133 (define-key wl-addrmgr-mode-map "p" 'wl-addrmgr-prev)
134 (define-key wl-addrmgr-mode-map [down] 'wl-addrmgr-next)
135 (define-key wl-addrmgr-mode-map [up] 'wl-addrmgr-prev)
137 (define-key wl-addrmgr-mode-map "s" 'wl-addrmgr-sort)
139 (define-key wl-addrmgr-mode-map "a" 'wl-addrmgr-add)
140 (define-key wl-addrmgr-mode-map "d" 'wl-addrmgr-delete)
141 (define-key wl-addrmgr-mode-map "e" 'wl-addrmgr-edit)
142 (define-key wl-addrmgr-mode-map "\n" 'wl-addrmgr-edit)
143 (define-key wl-addrmgr-mode-map "\r" 'wl-addrmgr-edit)
145 (define-key wl-addrmgr-mode-map "q" 'wl-addrmgr-quit)
146 (define-key wl-addrmgr-mode-map "\C-c\C-k" 'wl-addrmgr-quit)
148 (define-key wl-addrmgr-mode-map "C" 'wl-addrmgr-change-method)
150 (define-key wl-addrmgr-mode-map "Z" 'wl-addrmgr-reload)
151 (define-key wl-addrmgr-mode-map "\C-c\C-l" 'wl-addrmgr-redraw))
153 (defun wl-addrmgr-mode ()
154 "Major mode for Wanderlust address management.
155 See info under Wanderlust for full documentation.
157 \\{wl-addrmgr-mode-map}"
158 (kill-all-local-variables)
159 (setq mode-name "Address"
160 major-mode 'wl-addrmgr-mode)
161 (wl-mode-line-buffer-identification
162 '("Wanderlust: Address (" wl-addrmgr-method-name ")"))
163 (use-local-map wl-addrmgr-mode-map)
164 (setq buffer-read-only t))
166 (defun wl-addrmgr-address-entry-list (field)
167 "Return address list."
170 (nth 1 (std11-extract-address-components addr)))
174 (elmo-multiple-fields-body-list (list field) mail-header-separator)
177 (defun wl-addrmgr-pickup-entry-list (buffer)
178 "Return a list of address entiry from BUFFER."
180 (with-current-buffer buffer
183 (let ((structure (std11-extract-address-components addr)))
184 (list (cadr structure)
185 (or (car structure) "")
186 (or (car structure) ""))))
190 (elmo-multiple-fields-body-list '("to" "cc" "bcc")
191 mail-header-separator)
194 (defun wl-addrmgr-merge-entries (base-list append-list)
195 "Return a merged list of address entiry."
196 (dolist (entry append-list)
197 (unless (assoc (car entry) base-list)
198 (setq base-list (nconc base-list (list entry)))))
203 "Start an Address manager."
205 (let ((buffer (if (eq major-mode 'wl-draft-mode) (current-buffer)))
206 (already-list (list (cons 'to (wl-addrmgr-address-entry-list "to"))
207 (cons 'cc (wl-addrmgr-address-entry-list "cc"))
208 (cons 'bcc (wl-addrmgr-address-entry-list "bcc")))))
209 (if (eq major-mode 'wl-draft-mode)
210 (if (get-buffer-window wl-addrmgr-buffer-name)
212 (split-window (selected-window)
213 (- (window-height (selected-window))
214 wl-addrmgr-buffer-lines))
215 (select-window (next-window))
216 ;; Non-nil means display-buffer should make new windows.
217 (let ((pop-up-windows nil))
219 (get-buffer-create wl-addrmgr-buffer-name))))
220 (switch-to-buffer (get-buffer-create wl-addrmgr-buffer-name)))
221 (set-buffer wl-addrmgr-buffer-name)
223 (unless wl-addrmgr-method
224 (setq wl-addrmgr-method wl-addrmgr-default-method
225 wl-addrmgr-method-name (symbol-name wl-addrmgr-default-method)))
226 (unless wl-addrmgr-sort-key
227 (setq wl-addrmgr-sort-key wl-addrmgr-default-sort-key))
228 (unless wl-addrmgr-sort-order
229 (setq wl-addrmgr-sort-order wl-addrmgr-default-sort-order))
230 (setq wl-addrmgr-draft-buffer buffer)
231 (setq wl-addrmgr-list
232 (wl-addrmgr-merge-entries (wl-addrmgr-list)
233 (wl-addrmgr-pickup-entry-list buffer)))
234 (wl-addrmgr-draw already-list)
235 (setq wl-addrmgr-unknown-list already-list)
236 (wl-addrmgr-goto-top)))
238 (defun wl-addrmgr-goto-top ()
240 (goto-char (point-min))
246 (defun wl-addrmgr-goto-bottom ()
248 (goto-char (point-max))
252 (defun wl-addrmgr-reload ()
253 "Reload addresses entries."
255 (setq wl-addrmgr-list (wl-addrmgr-list 'reload))
258 (defun wl-addrmgr-redraw ()
259 "Redraw addresses entries."
261 (let ((rcpt (wl-addrmgr-mark-check)))
262 (wl-addrmgr-draw (list (cons 'to (nth 0 rcpt))
263 (cons 'cc (nth 1 rcpt))
264 (cons 'bcc (nth 2 rcpt)))))
265 (wl-addrmgr-goto-top))
267 (defun wl-addrmgr-sort-list (key list order)
275 (setq sorted (sort list `(lambda (a b) (string< (nth ,pos a)
277 (if (eq order 'descending)
282 (defun wl-addrmgr-insert-line (entry)
283 (let ((real (nth 2 entry))
289 (setq real (wl-set-string-width wl-addrmgr-realname-width real))
290 (put-text-property 0 (length real) 'face
291 wl-addrmgr-realname-face
293 (setq pet (wl-set-string-width wl-addrmgr-petname-width pet))
294 (put-text-property 0 (length pet) 'face
295 wl-addrmgr-petname-face
297 (setq addr (copy-sequence addr))
298 (put-text-property 0 (length addr) 'face
299 wl-addrmgr-address-face
303 (- wl-addrmgr-line-width 4)
304 (concat real " " pet " " addr)))
305 (put-text-property beg (point) 'wl-addrmgr-entry entry)))
307 (defun wl-addrmgr-search-forward-address (address)
308 "Search forward from point for ADDRESS.
309 Return nil if no ADDRESS exists."
313 (if (string= address (car (wl-addrmgr-address-entry)))
320 (defun wl-addrmgr-draw (already-list)
321 "Show recipients mail addresses."
323 (let ((buffer-read-only nil)
324 list field addrs beg real pet addr)
326 (goto-char (point-min))
329 (wl-set-string-width wl-addrmgr-realname-width
332 (wl-set-string-width wl-addrmgr-petname-width
336 (make-string wl-addrmgr-realname-width ?-)
338 (make-string wl-addrmgr-petname-width ?-)
340 (unless wl-addrmgr-list (insert "\n"))
341 (dolist (entry (wl-addrmgr-sort-list wl-addrmgr-sort-key
342 (copy-sequence wl-addrmgr-list)
343 wl-addrmgr-sort-order))
345 (wl-addrmgr-insert-line entry))
346 (set-buffer-modified-p nil)
348 (setq list (car already-list)
352 (goto-char (point-min))
353 (when (wl-addrmgr-search-forward-address (car addrs))
354 (wl-addrmgr-mark-write field)
355 (setcdr list (delq (car addrs) (cdr list))))
356 (setq addrs (cdr addrs)))
357 (setq already-list (cdr already-list))))))
359 (defun wl-addrmgr-next ()
360 "Move cursor next line."
363 (let ((current (count-lines (point-min) (point)))
367 (when (setq first (next-single-property-change (point) 'wl-addrmgr-entry
377 (defun wl-addrmgr-prev ()
378 "Move cursor prev line."
380 (let ((current (count-lines (point-min) (point))))
386 (goto-char (point-min))
393 (defun wl-addrmgr-quit-yes ()
394 (let ((draft-buffer wl-addrmgr-draft-buffer))
395 (if (and draft-buffer
396 (buffer-live-p draft-buffer)
397 (null (get-buffer-window draft-buffer 'visible)))
398 (switch-to-buffer draft-buffer)
399 (unless (one-window-p)
401 (kill-buffer wl-addrmgr-buffer-name)
402 (if (and draft-buffer (not (one-window-p)))
403 (switch-to-buffer-other-window draft-buffer))))
405 (defun wl-addrmgr-quit ()
406 "Exit from electric reference mode without inserting reference."
408 (let ((rcpt (wl-addrmgr-mark-check)))
412 (when (y-or-n-p "There is marked address. Quit wl-addrmgr really? ")
413 (wl-addrmgr-quit-yes))
414 (wl-addrmgr-quit-yes)))
417 (defun wl-addrmgr-mark-set-to ()
420 (wl-addrmgr-mark-write 'to)
423 (defun wl-addrmgr-mark-set-cc ()
426 (wl-addrmgr-mark-write 'cc)
429 (defun wl-addrmgr-mark-set-bcc ()
432 (wl-addrmgr-mark-write 'bcc)
435 (defun wl-addrmgr-unmark ()
438 (let ((entry (wl-addrmgr-address-entry))
442 (delete-region (point) (progn (end-of-line)(point)))
443 (wl-addrmgr-insert-line entry))
444 (set-buffer-modified-p nil)
447 (defun wl-addrmgr-sort ()
448 "Sort address entry."
450 (setq wl-addrmgr-sort-key (intern
452 (format "Sort By (%s): "
453 (symbol-name wl-addrmgr-sort-key))
454 '(("address")("realname")("petname")("none"))
456 (symbol-name wl-addrmgr-sort-key))))
457 (if (eq wl-addrmgr-sort-key 'none)
459 (setq wl-addrmgr-sort-order (intern
461 (format "Sort Order (%s): "
462 (symbol-name wl-addrmgr-sort-order))
463 '(("ascending") ("descending"))
465 (symbol-name wl-addrmgr-sort-order))))
466 (wl-addrmgr-redraw)))
469 (defun wl-addrmgr-method-call (method &rest args)
470 (apply (intern (concat "wl-addrmgr-"
471 (symbol-name wl-addrmgr-method)
472 "-" (symbol-name method)))
475 (defun wl-addrmgr-change-method ()
477 (setq wl-addrmgr-method (intern
478 (setq wl-addrmgr-method-name
480 (format "Method (%s): "
481 (symbol-name wl-addrmgr-method))
482 (mapcar (lambda (method)
483 (list (symbol-name method)))
484 wl-addrmgr-method-list)
486 (symbol-name wl-addrmgr-method)))))
489 (defun wl-addrmgr-list (&optional reload)
490 "List address entries."
491 (wl-addrmgr-method-call 'list reload))
493 (defun wl-addrmgr-add ()
496 (let ((entry (wl-addrmgr-method-call 'add)))
497 (if (eq wl-addrmgr-sort-key 'none)
499 (setq wl-addrmgr-list (cons entry wl-addrmgr-list))
501 (message "Added `%s'." (wl-string (car entry)))))
503 (defun wl-addrmgr-delete ()
504 "Delete address entry."
506 (let ((addr (wl-string (car (wl-addrmgr-address-entry))))
509 (y-or-n-p (format "Delete '%s'? " addr)))
510 (setq lines (count-lines (point-min) (point)))
511 (wl-addrmgr-method-call 'delete addr)
512 (setq wl-addrmgr-list (delq (assoc addr wl-addrmgr-list)
515 (forward-line (- lines 2))
516 (message "Deleted `%s'." addr))))
518 (defun wl-addrmgr-edit ()
519 "Edit address entry."
521 (let ((orig (wl-addrmgr-address-entry))
523 (setq entry (wl-addrmgr-method-call 'edit (wl-string (car orig))))
524 (setq lines (count-lines (point-min) (point)))
525 (if (eq wl-addrmgr-sort-key 'none)
527 (setq wl-addrmgr-list (delq (assoc (car orig) wl-addrmgr-list)
529 wl-addrmgr-list (cons entry wl-addrmgr-list))
531 (forward-line (- lines 1))
532 (message "Modified `%s'." (wl-string (car entry)))))
534 ;;; local address book implementation.
535 (defun wl-addrmgr-local-list (reload)
536 (if (or (null wl-address-list) reload)
538 (copy-sequence wl-address-list))
540 (defun wl-addrmgr-local-add ()
541 (wl-address-add-or-change nil nil 'addr-too))
543 (defun wl-addrmgr-local-edit (address)
544 (wl-address-add-or-change address nil 'addr-too))
546 (defun wl-addrmgr-local-delete (address)
547 (wl-address-delete address))
549 ;;; LDAP implementation (Implement Me)
553 (defun wl-addrmgr-address-entry ()
556 (get-text-property (previous-single-property-change
557 (point) 'wl-addrmgr-entry nil
563 (defun wl-addrmgr-mark-write (&optional mark)
564 "Set MARK to the current address entry."
567 (unless (< (count-lines (point-min) (point)) 3)
568 (let ((buffer-read-only nil) beg end)
576 (insert (make-string (- 4 (current-column)) ? ))
579 (setq end (progn (end-of-line)
581 (put-text-property beg end 'face nil)
582 (wl-highlight-message beg end nil))
583 (set-buffer-modified-p nil)
587 (defun wl-addrmgr-apply ()
589 (let ((rcpt (wl-addrmgr-mark-check 'full)))
590 (when (or (or (nth 0 rcpt)
593 (or (cdr (assq 'to wl-addrmgr-unknown-list))
594 (cdr (assq 'cc wl-addrmgr-unknown-list))
595 (cdr (assq 'bcc wl-addrmgr-unknown-list))))
596 (wl-addrmgr-apply-exec (wl-addrmgr-mark-check 'full)))
597 (wl-addrmgr-quit-yes)))
599 (defun wl-addrmgr-mark-check (&optional full)
600 "Return list of recipients (TO CC BCC)."
601 (save-excursion ; save cursor POINT
602 (goto-char (point-min))
604 (let (to-list cc-list bcc-list mark addr realname)
605 (while (and (not (eobp))
606 (re-search-forward "^\\([^ ]+:\\) " nil t))
607 (setq mark (match-string 1))
608 (setq addr (car (wl-addrmgr-address-entry)))
609 (setq realname (nth 2 (wl-addrmgr-address-entry)))
611 ((string= mark "To:")
614 (not (or (string= realname "")
615 (string-match ".*:.*;$" addr))))
617 (wl-address-quote-specials realname)
621 ((string= mark "Cc:")
624 (not (or (string= realname "")
625 (string-match ".*:.*;$" addr))))
627 (wl-address-quote-specials realname)
631 ((string= mark "Bcc:")
634 (not (or (string= realname "")
635 (string-match ".*:.*;$" addr))))
637 (wl-address-quote-specials realname)
641 (list to-list cc-list bcc-list))))
643 (defun wl-addrmgr-apply-exec (rcpt)
644 (let ((to (nconc (nth 0 rcpt) (cdr (assq 'to wl-addrmgr-unknown-list))))
645 (cc (nconc (nth 1 rcpt) (cdr (assq 'cc wl-addrmgr-unknown-list))))
646 (bcc (nconc (nth 2 rcpt) (cdr (assq 'bcc wl-addrmgr-unknown-list))))
648 (setq clist (list (cons "Bcc" (if bcc (mapconcat 'identity bcc ",\n\t")))
649 (cons "Cc" (if cc (mapconcat 'identity cc ",\n\t")))
650 (cons "To" (if to (mapconcat 'identity to ",\n\t")))))
651 (when (or (null wl-addrmgr-draft-buffer)
652 (not (buffer-live-p wl-addrmgr-draft-buffer)))
653 (setq wl-addrmgr-draft-buffer (save-window-excursion
654 (call-interactively 'wl-draft)
656 (with-current-buffer wl-addrmgr-draft-buffer
657 (setq from (std11-field-body "From"))
659 (setq clist (append clist (list (cons "From" from)))))
660 (wl-addrmgr-mark-exec-sub clist))))
662 (defun wl-addrmgr-replace-field (field content)
663 "Insert FIELD with CONTENT to the top of the header fields."
666 (let ((case-fold-search t)
667 (inhibit-read-only t) ;; added by teranisi.
669 (std11-narrow-to-header mail-header-separator)
670 (goto-char (point-min))
671 (while (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
677 (re-search-forward "^[^ \t]" nil 'move)
679 (delete-region beg (point))))
682 (goto-char (point-min))
683 (insert (concat field ": " content "\n")))))))
685 (defun wl-addrmgr-mark-exec-sub (list)
687 (wl-addrmgr-replace-field (car pair) (cdr pair)))
688 ;; from wl-template.el
690 (if wl-highlight-body-too
691 (let ((beg (point-min))
693 (put-text-property beg end 'face nil)
694 (wl-highlight-message beg end t))))
697 (product-provide (provide 'wl-addrmgr) (require 'wl-version))
699 ;;; wl-addrmgr.el ends here