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       (beginning-of-line)
 443       (delete-region (point) (progn (end-of-line)(point)))
 444       (wl-addrmgr-insert-line entry))
 445     (set-buffer-modified-p nil)
 446     (wl-addrmgr-next)))
 447
 448 (defun wl-addrmgr-sort ()
 449   "Sort address entry."
 450   (interactive)
 451   (setq wl-addrmgr-sort-key (intern
 452                              (completing-read
 453                               (format "Sort By (%s): "
 454                                       (symbol-name wl-addrmgr-sort-key))
 455                               '(("address")("realname")("petname")("none"))
 456                               nil t nil nil
 457                               (symbol-name wl-addrmgr-sort-key))))
 458   (if (eq wl-addrmgr-sort-key 'none)
 459       (wl-addrmgr-reload)
 460     (setq wl-addrmgr-sort-order (intern
 461                                  (completing-read
 462                                   (format "Sort Order (%s): "
 463                                           (symbol-name wl-addrmgr-sort-order))
 464                                   '(("ascending") ("descending"))
 465                                   nil t nil nil
 466                                   (symbol-name wl-addrmgr-sort-order))))
 467     (wl-addrmgr-redraw)))
 468
 469 ;;; Backend methods.
 470 (defun wl-addrmgr-method-call (method &rest args)
 471   (apply (intern (concat "wl-addrmgr-"
 472                          (symbol-name wl-addrmgr-method)
 473                          "-" (symbol-name method)))
 474          args))
 475
 476 (defun wl-addrmgr-change-method ()
 477   (interactive)
 478   (setq wl-addrmgr-method (intern
 479                            (setq wl-addrmgr-method-name
 480                                  (completing-read
 481                                   (format "Method (%s): "
 482                                           (symbol-name wl-addrmgr-method))
 483                                   (mapcar (lambda (method)
 484                                             (list (symbol-name method)))
 485                                           wl-addrmgr-method-list)
 486                                   nil t nil nil
 487                                   (symbol-name wl-addrmgr-method)))))
 488   (wl-addrmgr-redraw))
 489
 490 (defun wl-addrmgr-list (&optional reload)
 491   "List address entries."
 492   (wl-addrmgr-method-call 'list reload))
 493
 494 (defun wl-addrmgr-add ()
 495   "Add address entry."
 496   (interactive)
 497   (let ((entry (wl-addrmgr-method-call 'add)))
 498     (if (eq wl-addrmgr-sort-key 'none)
 499         (wl-addrmgr-reload)
 500       (setq wl-addrmgr-list (cons entry wl-addrmgr-list))
 501       (wl-addrmgr-redraw))
 502     (message "Added `%s'." (wl-string (car entry)))))
 503
 504 (defun wl-addrmgr-delete ()
 505   "Delete address entry."
 506   (interactive)
 507   (let ((addr (wl-string (car (wl-addrmgr-address-entry))))
 508         lines)
 509     (when (and addr
 510                (y-or-n-p (format "Delete '%s'? " addr)))
 511       (setq lines (count-lines (point-min) (point)))
 512       (wl-addrmgr-method-call 'delete addr)
 513       (setq wl-addrmgr-list (delq (assoc addr wl-addrmgr-list)
 514                                   wl-addrmgr-list))
 515       (wl-addrmgr-redraw)
 516       (forward-line (- lines 2))
 517       (message "Deleted `%s'." addr))))
 518
 519 (defun wl-addrmgr-edit ()
 520   "Edit address entry."
 521   (interactive)
 522   (let ((orig (wl-addrmgr-address-entry))
 523         entry lines)
 524     (setq entry (wl-addrmgr-method-call 'edit (wl-string (car orig))))
 525     (setq lines (count-lines (point-min) (point)))
 526     (if (eq wl-addrmgr-sort-key 'none)
 527         (wl-addrmgr-reload)
 528       (setq wl-addrmgr-list (delq (assoc (car orig) wl-addrmgr-list)
 529                                   wl-addrmgr-list)
 530             wl-addrmgr-list (cons entry wl-addrmgr-list))
 531       (wl-addrmgr-redraw))
 532     (forward-line (- lines 1))
 533     (message "Modified `%s'." (wl-string (car entry)))))
 534
 535 ;;; local address book implementation.
 536 (defun wl-addrmgr-local-list (reload)
 537   (if (or (null wl-address-list) reload)
 538       (wl-address-init))
 539   (copy-sequence wl-address-list))
 540
 541 (defun wl-addrmgr-local-add ()
 542   (wl-address-add-or-change nil nil 'addr-too))
 543
 544 (defun wl-addrmgr-local-edit (address)
 545   (wl-address-add-or-change address nil 'addr-too))
 546
 547 (defun wl-addrmgr-local-delete (address)
 548   (wl-address-delete address))
 549
 550 ;;; LDAP implementation (Implement Me)
 551
 552 ;;; Operations.
 553
 554 (defun wl-addrmgr-address-entry ()
 555   (save-excursion
 556     (end-of-line)
 557     (get-text-property (previous-single-property-change
 558                         (point) 'wl-addrmgr-entry nil
 559                         (progn
 560                           (beginning-of-line)
 561                           (point)))
 562                        'wl-addrmgr-entry)))
 563
 564 (defun wl-addrmgr-mark-write (&optional mark)
 565   "Set MARK to the current address entry."
 566   (save-excursion
 567     (end-of-line)
 568     (unless (< (count-lines (point-min) (point)) 3)
 569       (let ((buffer-read-only nil) beg end)
 570         (beginning-of-line)
 571         (delete-char 4)
 572         (insert (case mark
 573                   (to "To: ")
 574                   (cc "Cc: ")
 575                   (bcc "Bcc:")
 576                   (t "    ")))
 577         (insert (make-string (- 4 (current-column)) ? ))
 578         (beginning-of-line)
 579         (setq beg (point))
 580         (setq end (progn (end-of-line)
 581                          (point)))
 582         (put-text-property beg end 'face nil)
 583         (wl-highlight-message beg end nil))
 584       (set-buffer-modified-p nil)
 585       (beginning-of-line)
 586       (forward-char 4))))
 587
 588 (defun wl-addrmgr-apply ()
 589   (interactive)
 590   (let ((rcpt (wl-addrmgr-mark-check 'full)))
 591     (when (or (or (nth 0 rcpt)
 592                   (nth 1 rcpt)
 593                   (nth 2 rcpt))
 594               (or (cdr (assq 'to wl-addrmgr-unknown-list))
 595                   (cdr (assq 'cc wl-addrmgr-unknown-list))
 596                   (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 597       (wl-addrmgr-apply-exec (wl-addrmgr-mark-check 'full)))
 598     (wl-addrmgr-quit-yes)))
 599
 600 (defun wl-addrmgr-mark-check (&optional full)
 601   "Return list of recipients (TO CC BCC)."
 602   (save-excursion                       ; save cursor POINT
 603     (goto-char (point-min))
 604     (forward-line 2)
 605     (let (to-list cc-list bcc-list mark addr realname)
 606       (while (and (not (eobp))
 607                   (re-search-forward "^\\([^ ]+:\\) " nil t))
 608         (setq mark (match-string 1))
 609         (setq addr (car (wl-addrmgr-address-entry)))
 610         (setq realname (nth 2 (wl-addrmgr-address-entry)))
 611         (cond
 612          ((string= mark "To:")
 613           (setq to-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                          to-list)))
 622          ((string= mark "Cc:")
 623           (setq cc-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                          cc-list)))
 632          ((string= mark "Bcc:")
 633           (setq bcc-list (cons
 634                           (if (and full
 635                                    (not (or (string= realname "")
 636                                             (string-match ".*:.*;$" addr))))
 637                               (concat
 638                                (wl-address-quote-specials realname)
 639                                " <" addr">")
 640                             addr)
 641                           bcc-list)))))
 642       (list to-list cc-list bcc-list))))
 643
 644 (defun wl-addrmgr-apply-exec (rcpt)
 645   (let ((to (nconc (nth 0 rcpt) (cdr (assq 'to wl-addrmgr-unknown-list))))
 646         (cc (nconc (nth 1 rcpt) (cdr (assq 'cc wl-addrmgr-unknown-list))))
 647         (bcc (nconc (nth 2 rcpt) (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 648         from clist)
 649     (setq clist (list (cons "Bcc" (if bcc (mapconcat 'identity bcc ",\n\t")))
 650                       (cons "Cc" (if cc (mapconcat 'identity cc ",\n\t")))
 651                       (cons "To" (if to (mapconcat 'identity to ",\n\t")))))
 652     (when (or (null wl-addrmgr-draft-buffer)
 653               (not (buffer-live-p wl-addrmgr-draft-buffer)))
 654       (setq wl-addrmgr-draft-buffer (save-window-excursion
 655                                       (call-interactively 'wl-draft)
 656                                       (current-buffer))))
 657     (with-current-buffer wl-addrmgr-draft-buffer
 658       (setq from (std11-field-body "From"))
 659       (if from
 660           (setq clist (append clist (list (cons "From" from)))))
 661       (wl-addrmgr-mark-exec-sub clist))))
 662
 663 (defun wl-addrmgr-replace-field (field content)
 664   "Insert FIELD with CONTENT to the top of the header fields."
 665   (save-excursion
 666     (save-restriction
 667       (let ((case-fold-search t)
 668             (inhibit-read-only t) ;; added by teranisi.
 669             beg)
 670         (std11-narrow-to-header mail-header-separator)
 671         (goto-char (point-min))
 672         (while (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
 673           ;; delete field
 674           (progn
 675             (save-excursion
 676               (beginning-of-line)
 677               (setq beg (point)))
 678             (re-search-forward "^[^ \t]" nil 'move)
 679             (beginning-of-line)
 680             (delete-region beg (point))))
 681         (when content
 682           ;; add field to top.
 683           (goto-char (point-min))
 684           (insert (concat field ": " content "\n")))))))
 685
 686 (defun wl-addrmgr-mark-exec-sub (list)
 687   (dolist (pair list)
 688     (wl-addrmgr-replace-field (car pair) (cdr pair)))
 689   ;; from wl-template.el
 690   ;; rehighlight
 691   (if wl-highlight-body-too
 692       (let ((beg (point-min))
 693             (end (point-max)))
 694         (put-text-property beg end 'face nil)
 695         (wl-highlight-message beg end t))))
 696
 697 (require 'product)
 698 (product-provide (provide 'wl-addrmgr) (require 'wl-version))
 699
 700 ;;; wl-addrmgr.el ends here