wl/wl-addrmgr.el

   1 ;;; wl-addrmgr.el --- Address manager for Wanderlust.
   2
   3 ;; Copyright (C) 2001 Kitamoto Tsuyoshi <tsuyoshi.kitamoto@city.sapporo.jp>
   4 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
   5
   6 ;; Author: Kitamoto Tsuyoshi <tsuyoshi.kitamoto@city.sapporo.jp>
   7 ;;         Yuuichi Teranishi <teranisi@gohome.org>
   8 ;; Keywords: mail, net news
   9
  10 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
  11
  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)
  15 ;; any later version.
  16 ;;
  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.
  21 ;;
  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.
  26 ;;
  27
  28 ;;; Commentary:
  29 ;;   Edit To:, Cc:, Bcc: fields interactively from E-Mail address list
  30 ;;   on ~/.address file.
  31
  32 ;;; Code:
  33 ;;
  34
  35 (require 'wl-address)
  36 (require 'wl-draft)
  37 (eval-when-compile (require 'cl))
  38
  39 ;; Variables
  40 (defgroup wl-addrmgr nil
  41   "Wanderlust Address manager."
  42   :prefix "wl-"
  43   :group 'wl)
  44
  45 (defcustom wl-addrmgr-buffer-lines 10
  46   "*Buffer lines for ADDRMGR buffer for draft."
  47   :type 'integer
  48   :group 'wl-addrmgr)
  49
  50 (defcustom wl-addrmgr-default-sort-key 'realname
  51   "Default element for sort."
  52   :type '(choice '(address realname petname none))
  53   :group 'wl-addrmgr)
  54
  55 (defcustom wl-addrmgr-default-sort-order 'ascending
  56   "Default element for sort."
  57   :type '(choice '(ascending descending))
  58   :group 'wl-addrmgr)
  59
  60 (defcustom wl-addrmgr-realname-width 17
  61   "Width for realname."
  62   :type 'integer
  63   :group 'wl-addrmgr)
  64
  65 (defcustom wl-addrmgr-petname-width 10
  66   "Width for petname."
  67   :type 'integer
  68   :group 'wl-addrmgr)
  69
  70 (defcustom wl-addrmgr-line-width 78
  71   "Width for each line."
  72   :type 'integer
  73   :group 'wl-addrmgr)
  74
  75 (defcustom wl-addrmgr-realname-face 'wl-highlight-summary-normal-face
  76   "Face for realname."
  77   :type 'face
  78   :group 'wl-addrmgr)
  79
  80 (defcustom wl-addrmgr-petname-face 'wl-highlight-summary-unread-face
  81   "Face for petname."
  82   :type 'face
  83   :group 'wl-addrmgr)
  84
  85 (defcustom wl-addrmgr-address-face 'wl-highlight-summary-new-face
  86   "Face for address."
  87   :type 'face
  88   :group 'wl-addrmgr)
  89
  90 (defcustom wl-addrmgr-default-method 'local
  91   "Default access method for address entries."
  92   :type 'symbol
  93   :group 'wl-addrmgr)
  94
  95 (defvar wl-addrmgr-buffer-name "Address")
  96 (defvar wl-addrmgr-mode-map nil)
  97 (defvar wl-addrmgr-method-list '(local))
  98
  99 ;; buffer local variable.
 100 (defvar wl-addrmgr-draft-buffer nil)
 101 (defvar wl-addrmgr-unknown-list nil)
 102 (defvar wl-addrmgr-sort-key nil)
 103 (defvar wl-addrmgr-sort-order nil)
 104 (defvar wl-addrmgr-method nil)
 105 (defvar wl-addrmgr-list nil)
 106 (defvar wl-addrmgr-method-name nil)
 107
 108 (make-variable-buffer-local 'wl-addrmgr-draft-buffer)
 109 (make-variable-buffer-local 'wl-addrmgr-unknown-list)
 110 (make-variable-buffer-local 'wl-addrmgr-sort-key)
 111 (make-variable-buffer-local 'wl-addrmgr-sort-order)
 112 (make-variable-buffer-local 'wl-addrmgr-method)
 113 (make-variable-buffer-local 'wl-addrmgr-list)
 114 (make-variable-buffer-local 'wl-addrmgr-method-name)
 115
 116 ;;; Code
 117
 118 (if wl-addrmgr-mode-map
 119     nil
 120   (setq wl-addrmgr-mode-map (make-sparse-keymap))
 121   (define-key wl-addrmgr-mode-map "<"    'wl-addrmgr-goto-top)
 122   (define-key wl-addrmgr-mode-map ">"    'wl-addrmgr-goto-bottom)
 123   (define-key wl-addrmgr-mode-map "t"    'wl-addrmgr-mark-set-to)
 124   (define-key wl-addrmgr-mode-map "b"    'wl-addrmgr-mark-set-bcc)
 125   (define-key wl-addrmgr-mode-map "c"    'wl-addrmgr-mark-set-cc)
 126   (define-key wl-addrmgr-mode-map "u"    'wl-addrmgr-unmark)
 127   (define-key wl-addrmgr-mode-map "x"    'wl-addrmgr-apply)
 128
 129   (define-key wl-addrmgr-mode-map "\C-c\C-c" 'wl-addrmgr-apply)
 130
 131   (define-key wl-addrmgr-mode-map "n"    'wl-addrmgr-next)
 132   (define-key wl-addrmgr-mode-map "j"    'wl-addrmgr-next)
 133   (define-key wl-addrmgr-mode-map "k"    'wl-addrmgr-prev)
 134   (define-key wl-addrmgr-mode-map "p"    'wl-addrmgr-prev)
 135   (define-key wl-addrmgr-mode-map [down] 'wl-addrmgr-next)
 136   (define-key wl-addrmgr-mode-map [up]   'wl-addrmgr-prev)
 137
 138   (define-key wl-addrmgr-mode-map "s"    'wl-addrmgr-sort)
 139
 140   (define-key wl-addrmgr-mode-map "a"    'wl-addrmgr-add)
 141   (define-key wl-addrmgr-mode-map "d"    'wl-addrmgr-delete)
 142   (define-key wl-addrmgr-mode-map "e"    'wl-addrmgr-edit)
 143   (define-key wl-addrmgr-mode-map "\n"    'wl-addrmgr-edit)
 144   (define-key wl-addrmgr-mode-map "\r"    'wl-addrmgr-edit)
 145
 146   (define-key wl-addrmgr-mode-map "q"    'wl-addrmgr-quit)
 147   (define-key wl-addrmgr-mode-map "\C-c\C-k" 'wl-addrmgr-quit)
 148
 149   (define-key wl-addrmgr-mode-map "C"    'wl-addrmgr-change-method)
 150
 151   (define-key wl-addrmgr-mode-map "Z"    'wl-addrmgr-reload)
 152   (define-key wl-addrmgr-mode-map "\C-c\C-l" 'wl-addrmgr-redraw))
 153
 154 (defun wl-addrmgr-mode ()
 155   "Major mode for Wanderlust address management.
 156 See info under Wanderlust for full documentation.
 157
 158 \\{wl-addrmgr-mode-map}"
 159   (kill-all-local-variables)
 160   (setq mode-name "Address"
 161         major-mode 'wl-addrmgr-mode)
 162   (wl-mode-line-buffer-identification
 163    '("Wanderlust: Address (" wl-addrmgr-method-name ")"))
 164   (use-local-map wl-addrmgr-mode-map)
 165   (setq buffer-read-only t))
 166
 167 (defun wl-addrmgr-address-entry-list (field)
 168   "Return address list."
 169   (mapcar
 170    (lambda (addr)
 171      (nth 1 (std11-extract-address-components addr)))
 172    (wl-parse-addresses
 173     (mapconcat
 174      'identity
 175      (elmo-multiple-fields-body-list (list field) mail-header-separator)
 176      ","))))
 177
 178 (defun wl-addrmgr-pickup-entry-list (buffer)
 179   "Return a list of address entiry from BUFFER."
 180   (when buffer
 181     (with-current-buffer buffer
 182       (mapcar
 183        (lambda (addr)
 184          (let ((structure (std11-extract-address-components addr)))
 185            (list (cadr structure)
 186                  (or (car structure) "")
 187                  (or (car structure) ""))))
 188        (wl-parse-addresses
 189         (mapconcat
 190          'identity
 191          (elmo-multiple-fields-body-list '("to" "cc" "bcc")
 192                                          mail-header-separator)
 193          ","))))))
 194
 195 (defun wl-addrmgr-merge-entries (base-list append-list)
 196   "Return a merged list of address entiry."
 197   (dolist (entry append-list)
 198     (unless (assoc (car entry) base-list)
 199       (setq base-list (nconc base-list (list entry)))))
 200   base-list)
 201
 202 ;;;###autoload
 203 (defun wl-addrmgr ()
 204   "Start an Address manager."
 205   (interactive)
 206   (let ((buffer (if (eq major-mode 'wl-draft-mode) (current-buffer)))
 207         (already-list (list (cons 'to (wl-addrmgr-address-entry-list "to"))
 208                             (cons 'cc (wl-addrmgr-address-entry-list "cc"))
 209                             (cons 'bcc (wl-addrmgr-address-entry-list "bcc")))))
 210     (if (eq major-mode 'wl-draft-mode)
 211         (if (get-buffer-window wl-addrmgr-buffer-name)
 212             nil
 213           (split-window (selected-window)
 214                         (- (window-height (selected-window))
 215                            wl-addrmgr-buffer-lines))
 216           (select-window (next-window))
 217           ;;  Non-nil means display-buffer should make new windows.
 218           (let ((pop-up-windows nil))
 219             (switch-to-buffer
 220              (get-buffer-create wl-addrmgr-buffer-name))))
 221       (switch-to-buffer (get-buffer-create wl-addrmgr-buffer-name)))
 222     (set-buffer wl-addrmgr-buffer-name)
 223     (wl-addrmgr-mode)
 224     (unless wl-addrmgr-method
 225       (setq wl-addrmgr-method wl-addrmgr-default-method
 226             wl-addrmgr-method-name (symbol-name wl-addrmgr-default-method)))
 227     (unless wl-addrmgr-sort-key
 228       (setq wl-addrmgr-sort-key wl-addrmgr-default-sort-key))
 229     (unless wl-addrmgr-sort-order
 230       (setq wl-addrmgr-sort-order wl-addrmgr-default-sort-order))
 231     (setq wl-addrmgr-draft-buffer buffer)
 232     (setq wl-addrmgr-list
 233           (wl-addrmgr-merge-entries (wl-addrmgr-list)
 234                                     (wl-addrmgr-pickup-entry-list buffer)))
 235     (wl-addrmgr-draw already-list)
 236     (setq wl-addrmgr-unknown-list already-list)
 237     (wl-addrmgr-goto-top)))
 238
 239 (defun wl-addrmgr-goto-top ()
 240   (interactive)
 241   (goto-char (point-min))
 242   (forward-line 2)
 243   (condition-case nil
 244       (forward-char 4)
 245     (error)))
 246
 247 (defun wl-addrmgr-goto-bottom ()
 248   (interactive)
 249   (goto-char (point-max))
 250   (beginning-of-line)
 251   (forward-char 4))
 252
 253 (defun wl-addrmgr-reload ()
 254   "Reload addresses entries."
 255   (interactive)
 256   (setq wl-addrmgr-list (wl-addrmgr-list 'reload))
 257   (wl-addrmgr-redraw))
 258
 259 (defun wl-addrmgr-redraw ()
 260   "Redraw addresses entries."
 261   (interactive)
 262   (let ((rcpt (wl-addrmgr-mark-check)))
 263     (wl-addrmgr-draw (list (cons 'to (nth 0 rcpt))
 264                            (cons 'cc (nth 1 rcpt))
 265                            (cons 'bcc (nth 2 rcpt)))))
 266   (wl-addrmgr-goto-top))
 267
 268 (defun wl-addrmgr-sort-list (key list order)
 269   (let ((pos (case key
 270                (address 0)
 271                (petname 1)
 272                (realname 2)))
 273         sorted)
 274     (if pos
 275         (progn
 276           (setq sorted (sort list `(lambda (a b) (string< (nth ,pos a)
 277                                                           (nth ,pos b)))))
 278           (if (eq order 'descending)
 279               (nreverse sorted)
 280             sorted))
 281       list)))
 282
 283 (defun wl-addrmgr-insert-line (entry)
 284   (let ((real (nth 2 entry))
 285         (pet  (nth 1 entry))
 286         (addr (nth 0 entry))
 287         beg)
 288     (insert "     ")
 289     (setq beg (point))
 290     (setq real (wl-set-string-width wl-addrmgr-realname-width real))
 291     (put-text-property 0 (length real) 'face
 292                        wl-addrmgr-realname-face
 293                        real)
 294     (setq pet (wl-set-string-width wl-addrmgr-petname-width pet))
 295     (put-text-property 0 (length pet) 'face
 296                        wl-addrmgr-petname-face
 297                        pet)
 298     (setq addr (copy-sequence addr))
 299     (put-text-property 0 (length addr) 'face
 300                        wl-addrmgr-address-face
 301                        addr)
 302     (insert
 303      (wl-set-string-width
 304       (- wl-addrmgr-line-width 4)
 305       (concat real " " pet " " addr)))
 306     (put-text-property beg (point) 'wl-addrmgr-entry entry)))
 307
 308 (defun wl-addrmgr-search-forward-address (address)
 309   "Search forward from point for ADDRESS.
 310 Return nil if no ADDRESS exists."
 311   (let ((pos (point)))
 312     (if (catch 'found
 313             (while (not (eobp))
 314               (if (string= address (car (wl-addrmgr-address-entry)))
 315                   (throw 'found t)
 316                 (forward-line))))
 317         (point)
 318       (goto-char pos)
 319       nil)))
 320
 321 (defun wl-addrmgr-draw (already-list)
 322   "Show recipients mail addresses."
 323   (save-excursion
 324     (let ((buffer-read-only nil)
 325           list field addrs beg real pet addr)
 326       (erase-buffer)
 327       (goto-char (point-min))
 328       (insert
 329        "Mark "
 330        (wl-set-string-width wl-addrmgr-realname-width
 331                             "Realname")
 332        " "
 333        (wl-set-string-width wl-addrmgr-petname-width
 334                             "Petname")
 335        " Address\n")
 336       (insert "---- "
 337               (make-string wl-addrmgr-realname-width ?-)
 338               " "
 339               (make-string wl-addrmgr-petname-width ?-)
 340               " ---------------")
 341       (unless wl-addrmgr-list (insert "\n"))
 342       (dolist (entry (wl-addrmgr-sort-list wl-addrmgr-sort-key
 343                                            (copy-sequence wl-addrmgr-list)
 344                                            wl-addrmgr-sort-order))
 345         (insert "\n")
 346         (wl-addrmgr-insert-line entry))
 347       (set-buffer-modified-p nil)
 348       (while already-list
 349         (setq list (car already-list)
 350               field (car list)
 351               addrs (cdr list))
 352         (while addrs
 353           (goto-char (point-min))
 354           (when (wl-addrmgr-search-forward-address (car addrs))
 355             (wl-addrmgr-mark-write field)
 356             (setcdr list (delq (car addrs) (cdr list))))
 357           (setq addrs (cdr addrs)))
 358         (setq already-list (cdr already-list))))))
 359
 360 (defun wl-addrmgr-next ()
 361   "Move cursor next line."
 362   (interactive)
 363   (end-of-line)
 364   (let ((current (count-lines (point-min) (point)))
 365         first)
 366     (cond
 367      ((<= current 2)
 368       (when (setq first (next-single-property-change (point) 'wl-addrmgr-entry
 369                                                      nil))
 370         (goto-char first)
 371         (beginning-of-line)
 372         (forward-char 4)))
 373      (t
 374       (forward-line)
 375       (beginning-of-line)
 376       (forward-char 4)))))
 377
 378 (defun wl-addrmgr-prev ()
 379   "Move cursor prev line."
 380   (interactive)
 381   (let ((current (count-lines (point-min) (point))))
 382     (cond
 383      ((= current 3)
 384       (beginning-of-line)
 385       (forward-char 4))
 386      ((< current 3)
 387       (goto-char (point-min))
 388       (forward-line 2)
 389       (forward-char 4))
 390      (t
 391       (forward-line -1)
 392       (forward-char 4)))))
 393
 394 (defun wl-addrmgr-quit-yes ()
 395   (let ((draft-buffer wl-addrmgr-draft-buffer))
 396     (if (and draft-buffer
 397              (buffer-live-p draft-buffer)
 398              (null (get-buffer-window draft-buffer 'visible)))
 399         (switch-to-buffer draft-buffer)
 400       (unless (one-window-p)
 401         (delete-window)))
 402     (kill-buffer wl-addrmgr-buffer-name)
 403     (if (and draft-buffer (not (one-window-p)))
 404         (switch-to-buffer-other-window draft-buffer))))
 405
 406 (defun wl-addrmgr-quit ()
 407   "Exit from electric reference mode without inserting reference."
 408   (interactive)
 409   (let ((rcpt (wl-addrmgr-mark-check)))
 410     (if (or (nth 0 rcpt)
 411             (nth 1 rcpt)
 412             (nth 2 rcpt))
 413         (when (y-or-n-p "There is marked address. Quit wl-addrmgr really? ")
 414           (wl-addrmgr-quit-yes))
 415       (wl-addrmgr-quit-yes)))
 416   (message ""))
 417
 418 (defun wl-addrmgr-mark-set-to ()
 419   "Marking To: sign."
 420   (interactive)
 421   (wl-addrmgr-mark-write 'to)
 422   (wl-addrmgr-next))
 423
 424 (defun wl-addrmgr-mark-set-cc ()
 425   "Marking Cc: sign."
 426   (interactive)
 427   (wl-addrmgr-mark-write 'cc)
 428   (wl-addrmgr-next))
 429
 430 (defun wl-addrmgr-mark-set-bcc ()
 431   "Marking Bcc: sign."
 432   (interactive)
 433   (wl-addrmgr-mark-write 'bcc)
 434   (wl-addrmgr-next))
 435
 436 (defun wl-addrmgr-unmark ()
 437   "Erase Marked sign."
 438   (interactive)
 439   (let ((entry (wl-addrmgr-address-entry))
 440         buffer-read-only)
 441     (save-excursion
 442       (delete-region (point-at-bol) (point-at-eol))
 443       (wl-addrmgr-insert-line entry))
 444     (set-buffer-modified-p nil)
 445     (wl-addrmgr-next)))
 446
 447 (defun wl-addrmgr-sort ()
 448   "Sort address entry."
 449   (interactive)
 450   (setq wl-addrmgr-sort-key (intern
 451                              (completing-read
 452                               (format "Sort By (%s): "
 453                                       (symbol-name wl-addrmgr-sort-key))
 454                               '(("address")("realname")("petname")("none"))
 455                               nil t nil nil
 456                               (symbol-name wl-addrmgr-sort-key))))
 457   (if (eq wl-addrmgr-sort-key 'none)
 458       (wl-addrmgr-reload)
 459     (setq wl-addrmgr-sort-order (intern
 460                                  (completing-read
 461                                   (format "Sort Order (%s): "
 462                                           (symbol-name wl-addrmgr-sort-order))
 463                                   '(("ascending") ("descending"))
 464                                   nil t nil nil
 465                                   (symbol-name wl-addrmgr-sort-order))))
 466     (wl-addrmgr-redraw)))
 467
 468 ;;; Backend methods.
 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)))
 473          args))
 474
 475 (defun wl-addrmgr-change-method ()
 476   (interactive)
 477   (setq wl-addrmgr-method (intern
 478                            (setq wl-addrmgr-method-name
 479                                  (completing-read
 480                                   (format "Method (%s): "
 481                                           (symbol-name wl-addrmgr-method))
 482                                   (mapcar (lambda (method)
 483                                             (list (symbol-name method)))
 484                                           wl-addrmgr-method-list)
 485                                   nil t nil nil
 486                                   (symbol-name wl-addrmgr-method)))))
 487   (wl-addrmgr-redraw))
 488
 489 (defun wl-addrmgr-list (&optional reload)
 490   "List address entries."
 491   (wl-addrmgr-method-call 'list reload))
 492
 493 (defun wl-addrmgr-add ()
 494   "Add address entry."
 495   (interactive)
 496   (let ((entry (wl-addrmgr-method-call 'add)))
 497     (if (eq wl-addrmgr-sort-key 'none)
 498         (wl-addrmgr-reload)
 499       (setq wl-addrmgr-list (cons entry wl-addrmgr-list))
 500       (wl-addrmgr-redraw))
 501     (message "Added `%s'." (wl-string (car entry)))))
 502
 503 (defun wl-addrmgr-delete ()
 504   "Delete address entry."
 505   (interactive)
 506   (let ((addr (wl-string (car (wl-addrmgr-address-entry))))
 507         lines)
 508     (when (and addr
 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)
 513                                   wl-addrmgr-list))
 514       (wl-addrmgr-redraw)
 515       (forward-line (- lines 2))
 516       (message "Deleted `%s'." addr))))
 517
 518 (defun wl-addrmgr-edit ()
 519   "Edit address entry."
 520   (interactive)
 521   (let ((orig (wl-addrmgr-address-entry))
 522         entry lines)
 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)
 526         (wl-addrmgr-reload)
 527       (setq wl-addrmgr-list (delq (assoc (car orig) wl-addrmgr-list)
 528                                   wl-addrmgr-list)
 529             wl-addrmgr-list (cons entry wl-addrmgr-list))
 530       (wl-addrmgr-redraw))
 531     (forward-line (- lines 1))
 532     (message "Modified `%s'." (wl-string (car entry)))))
 533
 534 ;;; local address book implementation.
 535 (defun wl-addrmgr-local-list (reload)
 536   (if (or (null wl-address-list) reload)
 537       (wl-address-init))
 538   (copy-sequence wl-address-list))
 539
 540 (defun wl-addrmgr-local-add ()
 541   (wl-address-add-or-change nil nil 'addr-too))
 542
 543 (defun wl-addrmgr-local-edit (address)
 544   (wl-address-add-or-change address nil 'addr-too))
 545
 546 (defun wl-addrmgr-local-delete (address)
 547   (wl-address-delete address))
 548
 549 ;;; LDAP implementation (Implement Me)
 550
 551 ;;; Operations.
 552
 553 (defun wl-addrmgr-address-entry ()
 554   (get-text-property (previous-single-property-change
 555                       (point-at-eol) 'wl-addrmgr-entry nil
 556                       (point-at-bol))
 557                      'wl-addrmgr-entry))
 558
 559 (defun wl-addrmgr-mark-write (&optional mark)
 560   "Set MARK to the current address entry."
 561   (save-excursion
 562     (unless (< (count-lines (point-min) (point-at-eol)) 3)
 563       (let ((buffer-read-only nil) beg end)
 564         (beginning-of-line)
 565         (delete-char 4)
 566         (insert (case mark
 567                   (to "To: ")
 568                   (cc "Cc: ")
 569                   (bcc "Bcc:")
 570                   (t "    ")))
 571         (insert (make-string (- 4 (current-column)) (string-to-char " ")))
 572         (setq beg (point-at-bol))
 573         (setq end (point-at-eol))
 574         (put-text-property beg end 'face nil)
 575         (wl-highlight-message beg end nil))
 576       (set-buffer-modified-p nil))))
 577
 578 (defun wl-addrmgr-apply ()
 579   (interactive)
 580   (let ((rcpt (wl-addrmgr-mark-check 'full)))
 581     (when (or (or (nth 0 rcpt)
 582                   (nth 1 rcpt)
 583                   (nth 2 rcpt))
 584               (or (cdr (assq 'to wl-addrmgr-unknown-list))
 585                   (cdr (assq 'cc wl-addrmgr-unknown-list))
 586                   (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 587       (wl-addrmgr-apply-exec (wl-addrmgr-mark-check 'full)))
 588     (wl-addrmgr-quit-yes)))
 589
 590 (defun wl-addrmgr-mark-check (&optional full)
 591   "Return list of recipients (TO CC BCC)."
 592   (save-excursion                       ; save cursor POINT
 593     (goto-char (point-min))
 594     (forward-line 2)
 595     (let (to-list cc-list bcc-list mark addr realname)
 596       (while (and (not (eobp))
 597                   (re-search-forward "^\\([^ ]+:\\) " nil t))
 598         (setq mark (match-string 1))
 599         (setq addr (car (wl-addrmgr-address-entry)))
 600         (setq realname (nth 2 (wl-addrmgr-address-entry)))
 601         (cond
 602          ((string= mark "To:")
 603           (setq to-list (cons
 604                          (if (and full
 605                                   (not (or (string= realname "")
 606                                            (string-match ".*:.*;$" addr))))
 607                              (concat
 608                               (wl-address-quote-specials realname)
 609                               " <" addr">")
 610                            addr)
 611                          to-list)))
 612          ((string= mark "Cc:")
 613           (setq cc-list (cons
 614                          (if (and full
 615                                   (not (or (string= realname "")
 616                                            (string-match ".*:.*;$" addr))))
 617                              (concat
 618                               (wl-address-quote-specials realname)
 619                               " <" addr">")
 620                            addr)
 621                          cc-list)))
 622          ((string= mark "Bcc:")
 623           (setq bcc-list (cons
 624                           (if (and full
 625                                    (not (or (string= realname "")
 626                                             (string-match ".*:.*;$" addr))))
 627                               (concat
 628                                (wl-address-quote-specials realname)
 629                                " <" addr">")
 630                             addr)
 631                           bcc-list)))))
 632       (list to-list cc-list bcc-list))))
 633
 634 (defun wl-addrmgr-apply-exec (rcpt)
 635   (let ((to (nconc (nth 0 rcpt) (cdr (assq 'to wl-addrmgr-unknown-list))))
 636         (cc (nconc (nth 1 rcpt) (cdr (assq 'cc wl-addrmgr-unknown-list))))
 637         (bcc (nconc (nth 2 rcpt) (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 638         from clist)
 639     (setq clist (list (cons "Bcc" (if bcc (mapconcat 'identity bcc ",\n\t")))
 640                       (cons "Cc" (if cc (mapconcat 'identity cc ",\n\t")))
 641                       (cons "To" (if to (mapconcat 'identity to ",\n\t")))))
 642     (when (or (null wl-addrmgr-draft-buffer)
 643               (not (buffer-live-p wl-addrmgr-draft-buffer)))
 644       (setq wl-addrmgr-draft-buffer (save-window-excursion
 645                                       (call-interactively 'wl-draft)
 646                                       (current-buffer))))
 647     (with-current-buffer wl-addrmgr-draft-buffer
 648       (setq from (std11-field-body "From"))
 649       (if from
 650           (setq clist (append clist (list (cons "From" from)))))
 651       (wl-addrmgr-mark-exec-sub clist))))
 652
 653 (defun wl-addrmgr-replace-field (field content)
 654   "Insert FIELD with CONTENT to the top of the header fields."
 655   (save-excursion
 656     (save-restriction
 657       (let ((case-fold-search t)
 658             (inhibit-read-only t) ;; added by teranisi.
 659             beg)
 660         (std11-narrow-to-header mail-header-separator)
 661         (goto-char (point-min))
 662         (while (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
 663           ;; delete field
 664           (progn
 665             (setq beg (point-at-bol))
 666             (re-search-forward "^[^ \t]" nil 'move)
 667             (delete-region beg (point-at-bol))
 668             (beginning-of-line)))
 669         (when content
 670           ;; add field to top.
 671           (goto-char (point-min))
 672           (insert (concat field ": " content "\n")))))))
 673
 674 (defun wl-addrmgr-mark-exec-sub (list)
 675   (dolist (pair list)
 676     (wl-addrmgr-replace-field (car pair) (cdr pair)))
 677   ;; from wl-template.el
 678   ;; rehighlight
 679   (if wl-highlight-body-too
 680       (let ((beg (point-min))
 681             (end (point-max)))
 682         (put-text-property beg end 'face nil)
 683         (wl-highlight-message beg end t))))
 684
 685 (require 'product)
 686 (product-provide (provide 'wl-addrmgr) (require 'wl-version))
 687
 688 ;;; wl-addrmgr.el ends here