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
  38 ;; Variables
  39 (defgroup wl-addrmgr nil
  40   "Wanderlust Address manager."
  41   :prefix "wl-"
  42   :group 'wl)
  43
  44 (defcustom wl-addrmgr-buffer-lines 10
  45   "*Buffer lines for ADDRMGR buffer for draft."
  46   :type 'integer
  47   :group 'wl-addrmgr)
  48
  49 (defcustom wl-addrmgr-default-sort-key 'realname
  50   "Default element for sort."
  51   :type '(choice '(address realname petname none))
  52   :group 'wl-addrmgr)
  53
  54 (defcustom wl-addrmgr-default-sort-order 'ascending
  55   "Default element for sort."
  56   :type '(choice '(ascending descending))
  57   :group 'wl-addrmgr)
  58
  59 (defcustom wl-addrmgr-realname-width 17
  60   "Width for realname."
  61   :type 'integer
  62   :group 'wl-addrmgr)
  63
  64 (defcustom wl-addrmgr-petname-width 10
  65   "Width for petname."
  66   :type 'integer
  67   :group 'wl-addrmgr)
  68
  69 (defcustom wl-addrmgr-line-width 78
  70   "Width for each line."
  71   :type 'integer
  72   :group 'wl-addrmgr)
  73
  74 (defcustom wl-addrmgr-realname-face 'wl-highlight-summary-normal-face
  75   "Face for realname."
  76   :type 'face
  77   :group 'wl-addrmgr)
  78
  79 (defcustom wl-addrmgr-petname-face 'wl-highlight-summary-unread-face
  80   "Face for petname."
  81   :type 'face
  82   :group 'wl-addrmgr)
  83
  84 (defcustom wl-addrmgr-address-face 'wl-highlight-summary-new-face
  85   "Face for address."
  86   :type 'face
  87   :group 'wl-addrmgr)
  88
  89 (defcustom wl-addrmgr-default-method 'local
  90   "Default access method for address entries."
  91   :type 'symbol
  92   :group 'wl-addrmgr)
  93
  94 (defvar wl-addrmgr-buffer-name "Address")
  95 (defvar wl-addrmgr-mode-map nil)
  96 (defvar wl-addrmgr-method-list '(local))
  97
  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)
 106
 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)
 114
 115 ;;; Code
 116
 117 (if wl-addrmgr-mode-map
 118     nil
 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)
 127
 128   (define-key wl-addrmgr-mode-map "\C-c\C-c" 'wl-addrmgr-apply)
 129
 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)
 136
 137   (define-key wl-addrmgr-mode-map "s"    'wl-addrmgr-sort)
 138
 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)
 144
 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)
 147
 148   (define-key wl-addrmgr-mode-map "C"    'wl-addrmgr-change-method)
 149
 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))
 152
 153 (defun wl-addrmgr-mode ()
 154   "Major mode for Wanderlust address management.
 155 See info under Wanderlust for full documentation.
 156
 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))
 165
 166 (defun wl-addrmgr-address-entry-list (field)
 167   "Return address list."
 168   (mapcar
 169    (lambda (addr)
 170      (nth 1 (std11-extract-address-components addr)))
 171    (wl-parse-addresses
 172     (mapconcat
 173      'identity
 174      (elmo-multiple-fields-body-list (list field) mail-header-separator)
 175      ","))))
 176
 177 (defun wl-addrmgr-pickup-entry-list (buffer)
 178   "Return a list of address entiry from BUFFER."
 179   (when buffer
 180     (with-current-buffer buffer
 181       (mapcar
 182        (lambda (addr)
 183          (let ((structure (std11-extract-address-components addr)))
 184            (list (cadr structure)
 185                  (or (car structure) "")
 186                  (or (car structure) ""))))
 187        (wl-parse-addresses
 188         (mapconcat
 189          'identity
 190          (elmo-multiple-fields-body-list '("to" "cc" "bcc")
 191                                          mail-header-separator)
 192          ","))))))
 193
 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)))))
 199   base-list)
 200
 201 ;;;###autoload
 202 (defun wl-addrmgr ()
 203   "Start an Address manager."
 204   (interactive)
 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)
 211             nil
 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))
 218             (switch-to-buffer
 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)
 222     (wl-addrmgr-mode)
 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)))
 237
 238 (defun wl-addrmgr-goto-top ()
 239   (interactive)
 240   (goto-char (point-min))
 241   (forward-line 2)
 242   (condition-case nil
 243       (forward-char 4)
 244     (error)))
 245
 246 (defun wl-addrmgr-goto-bottom ()
 247   (interactive)
 248   (goto-char (point-max))
 249   (beginning-of-line)
 250   (forward-char 4))
 251
 252 (defun wl-addrmgr-reload ()
 253   "Reload addresses entries."
 254   (interactive)
 255   (setq wl-addrmgr-list (wl-addrmgr-list 'reload))
 256   (wl-addrmgr-redraw))
 257
 258 (defun wl-addrmgr-redraw ()
 259   "Redraw addresses entries."
 260   (interactive)
 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))
 266
 267 (defun wl-addrmgr-sort-list (key list order)
 268   (let ((pos (case key
 269                (address 0)
 270                (petname 1)
 271                (realname 2)))
 272         sorted)
 273     (if pos
 274         (progn
 275           (setq sorted (sort list `(lambda (a b) (string< (nth ,pos a)
 276                                                           (nth ,pos b)))))
 277           (if (eq order 'descending)
 278               (nreverse sorted)
 279             sorted))
 280       list)))
 281
 282 (defun wl-addrmgr-insert-line (entry)
 283   (let ((real (nth 2 entry))
 284         (pet  (nth 1 entry))
 285         (addr (nth 0 entry))
 286         beg)
 287     (insert "     ")
 288     (setq beg (point))
 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
 292                        real)
 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
 296                        pet)
 297     (setq addr (copy-sequence addr))
 298     (put-text-property 0 (length addr) 'face
 299                        wl-addrmgr-address-face
 300                        addr)
 301     (insert
 302      (wl-set-string-width
 303       (- wl-addrmgr-line-width 4)
 304       (concat real " " pet " " addr)))
 305     (put-text-property beg (point) 'wl-addrmgr-entry entry)))
 306
 307 (defun wl-addrmgr-search-forward-address (address)
 308   "Search forward from point for ADDRESS.
 309 Return nil if no ADDRESS exists."
 310   (let ((pos (point)))
 311     (if (catch 'found
 312             (while (not (eobp))
 313               (if (string= address (car (wl-addrmgr-address-entry)))
 314                   (throw 'found t)
 315                 (forward-line))))
 316         (point)
 317       (goto-char pos)
 318       nil)))
 319
 320 (defun wl-addrmgr-draw (already-list)
 321   "Show recipients mail addresses."
 322   (save-excursion
 323     (let ((buffer-read-only nil)
 324           list field addrs beg real pet addr)
 325       (erase-buffer)
 326       (goto-char (point-min))
 327       (insert
 328        "Mark "
 329        (wl-set-string-width wl-addrmgr-realname-width
 330                             "Realname")
 331        " "
 332        (wl-set-string-width wl-addrmgr-petname-width
 333                             "Petname")
 334        " Address\n")
 335       (insert "---- "
 336               (make-string wl-addrmgr-realname-width ?-)
 337               " "
 338               (make-string wl-addrmgr-petname-width ?-)
 339               " ---------------")
 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))
 344         (insert "\n")
 345         (wl-addrmgr-insert-line entry))
 346       (set-buffer-modified-p nil)
 347       (while already-list
 348         (setq list (car already-list)
 349               field (car list)
 350               addrs (cdr list))
 351         (while addrs
 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))))))
 358
 359 (defun wl-addrmgr-next ()
 360   "Move cursor next line."
 361   (interactive)
 362   (end-of-line)
 363   (let ((current (count-lines (point-min) (point)))
 364         first)
 365     (cond
 366      ((<= current 2)
 367       (when (setq first (next-single-property-change (point) 'wl-addrmgr-entry
 368                                                      nil))
 369         (goto-char first)
 370         (beginning-of-line)
 371         (forward-char 4)))
 372      (t
 373       (forward-line)
 374       (beginning-of-line)
 375       (forward-char 4)))))
 376
 377 (defun wl-addrmgr-prev ()
 378   "Move cursor prev line."
 379   (interactive)
 380   (let ((current (count-lines (point-min) (point))))
 381     (cond
 382      ((= current 3)
 383       (beginning-of-line)
 384       (forward-char 4))
 385      ((< current 3)
 386       (goto-char (point-min))
 387       (forward-line 2)
 388       (forward-char 4))
 389      (t
 390       (forward-line -1)
 391       (forward-char 4)))))
 392
 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)
 400         (delete-window)))
 401     (kill-buffer wl-addrmgr-buffer-name)
 402     (if (and draft-buffer (not (one-window-p)))
 403         (switch-to-buffer-other-window draft-buffer))))
 404
 405 (defun wl-addrmgr-quit ()
 406   "Exit from electric reference mode without inserting reference."
 407   (interactive)
 408   (let ((rcpt (wl-addrmgr-mark-check)))
 409     (if (or (nth 0 rcpt)
 410             (nth 1 rcpt)
 411             (nth 2 rcpt))
 412         (when (y-or-n-p "There is marked address. Quit wl-addrmgr really? ")
 413           (wl-addrmgr-quit-yes))
 414       (wl-addrmgr-quit-yes)))
 415   (message ""))
 416
 417 (defun wl-addrmgr-mark-set-to ()
 418   "Marking To: sign."
 419   (interactive)
 420   (wl-addrmgr-mark-write 'to)
 421   (wl-addrmgr-next))
 422
 423 (defun wl-addrmgr-mark-set-cc ()
 424   "Marking Cc: sign."
 425   (interactive)
 426   (wl-addrmgr-mark-write 'cc)
 427   (wl-addrmgr-next))
 428
 429 (defun wl-addrmgr-mark-set-bcc ()
 430   "Marking Bcc: sign."
 431   (interactive)
 432   (wl-addrmgr-mark-write 'bcc)
 433   (wl-addrmgr-next))
 434
 435 (defun wl-addrmgr-unmark ()
 436   "Erase Marked sign."
 437   (interactive)
 438   (let ((entry (wl-addrmgr-address-entry))
 439         buffer-read-only)
 440     (save-excursion
 441       (beginning-of-line)
 442       (delete-region (point) (progn (end-of-line)(point)))
 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   (save-excursion
 555     (end-of-line)
 556     (get-text-property (previous-single-property-change
 557                         (point) 'wl-addrmgr-entry nil
 558                         (progn
 559                           (beginning-of-line)
 560                           (point)))
 561                        'wl-addrmgr-entry)))
 562
 563 (defun wl-addrmgr-mark-write (&optional mark)
 564   "Set MARK to the current address entry."
 565   (save-excursion
 566     (end-of-line)
 567     (unless (< (count-lines (point-min) (point)) 3)
 568       (let ((buffer-read-only nil) beg end)
 569         (beginning-of-line)
 570         (delete-char 4)
 571         (insert (case mark
 572                   (to "To: ")
 573                   (cc "Cc: ")
 574                   (bcc "Bcc:")
 575                   (t "    ")))
 576         (insert (make-string (- 4 (current-column)) ? ))
 577         (beginning-of-line)
 578         (setq beg (point))
 579         (setq end (progn (end-of-line)
 580                          (point)))
 581         (put-text-property beg end 'face nil)
 582         (wl-highlight-message beg end nil))
 583       (set-buffer-modified-p nil)
 584       (beginning-of-line)
 585       (forward-char 4))))
 586
 587 (defun wl-addrmgr-apply ()
 588   (interactive)
 589   (let ((rcpt (wl-addrmgr-mark-check 'full)))
 590     (when (or (or (nth 0 rcpt)
 591                   (nth 1 rcpt)
 592                   (nth 2 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)))
 598
 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))
 603     (forward-line 2)
 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)))
 610         (cond
 611          ((string= mark "To:")
 612           (setq to-list (cons
 613                          (if (and full
 614                                   (not (or (string= realname "")
 615                                            (string-match ".*:.*;$" addr))))
 616                              (concat
 617                               (wl-address-quote-specials realname)
 618                               " <" addr">")
 619                            addr)
 620                          to-list)))
 621          ((string= mark "Cc:")
 622           (setq cc-list (cons
 623                          (if (and full
 624                                   (not (or (string= realname "")
 625                                            (string-match ".*:.*;$" addr))))
 626                              (concat
 627                               (wl-address-quote-specials realname)
 628                               " <" addr">")
 629                            addr)
 630                          cc-list)))
 631          ((string= mark "Bcc:")
 632           (setq bcc-list (cons
 633                           (if (and full
 634                                    (not (or (string= realname "")
 635                                             (string-match ".*:.*;$" addr))))
 636                               (concat
 637                                (wl-address-quote-specials realname)
 638                                " <" addr">")
 639                             addr)
 640                           bcc-list)))))
 641       (list to-list cc-list bcc-list))))
 642
 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))))
 647         from clist)
 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)
 655                                       (current-buffer))))
 656     (with-current-buffer wl-addrmgr-draft-buffer
 657       (setq from (std11-field-body "From"))
 658       (if from
 659           (setq clist (append clist (list (cons "From" from)))))
 660       (wl-addrmgr-mark-exec-sub clist))))
 661
 662 (defun wl-addrmgr-replace-field (field content)
 663   "Insert FIELD with CONTENT to the top of the header fields."
 664   (save-excursion
 665     (save-restriction
 666       (let ((case-fold-search t)
 667             (inhibit-read-only t) ;; added by teranisi.
 668             beg)
 669         (std11-narrow-to-header mail-header-separator)
 670         (goto-char (point-min))
 671         (while (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
 672           ;; delete field
 673           (progn
 674             (save-excursion
 675               (beginning-of-line)
 676               (setq beg (point)))
 677             (re-search-forward "^[^ \t]" nil 'move)
 678             (beginning-of-line)
 679             (delete-region beg (point))))
 680         (when content
 681           ;; add field to top.
 682           (goto-char (point-min))
 683           (insert (concat field ": " content "\n")))))))
 684
 685 (defun wl-addrmgr-mark-exec-sub (list)
 686   (dolist (pair list)
 687     (wl-addrmgr-replace-field (car pair) (cdr pair)))
 688   ;; from wl-template.el
 689   ;; rehighlight
 690   (if wl-highlight-body-too
 691       (let ((beg (point-min))
 692             (end (point-max)))
 693         (put-text-property beg end 'face nil)
 694         (wl-highlight-message beg end t))))
 695
 696 (require 'product)
 697 (product-provide (provide 'wl-addrmgr) (require 'wl-version))
 698
 699 ;;; wl-addrmgr.el ends here