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 'identity (elmo-multiple-fields-body-list (list field)) ","))))
 173
 174 (defun wl-addrmgr-pickup-entry-list (buffer)
 175   "Return a list of address entiry from BUFFER."
 176   (when buffer
 177     (with-current-buffer buffer
 178       (mapcar
 179        (lambda (addr)
 180          (let ((structure (std11-extract-address-components addr)))
 181            (list (cadr structure)
 182                  (or (car structure) "")
 183                  (or (car structure) ""))))
 184        (wl-parse-addresses
 185         (mapconcat
 186          'identity
 187          (elmo-multiple-fields-body-list '("to" "cc" "bcc")) ","))))))
 188
 189 (defun wl-addrmgr-merge-entries (base-list append-list)
 190   "Return a merged list of address entiry."
 191   (dolist (entry append-list)
 192     (unless (assoc (car entry) base-list)
 193       (setq base-list (nconc base-list (list entry)))))
 194   base-list)
 195
 196 ;;;###autoload
 197 (defun wl-addrmgr ()
 198   "Start an Address manager."
 199   (interactive)
 200   (let ((buffer (if (eq major-mode 'wl-draft-mode) (current-buffer)))
 201         (already-list (list (cons 'to (wl-addrmgr-address-entry-list "to"))
 202                             (cons 'cc (wl-addrmgr-address-entry-list "cc"))
 203                             (cons 'bcc (wl-addrmgr-address-entry-list "bcc")))))
 204     (if (eq major-mode 'wl-draft-mode)
 205         (if (get-buffer-window wl-addrmgr-buffer-name)
 206             nil
 207           (split-window (selected-window)
 208                         (- (window-height (selected-window))
 209                            wl-addrmgr-buffer-lines))
 210           (select-window (next-window))
 211           ;;  Non-nil means display-buffer should make new windows.
 212           (let ((pop-up-windows nil))
 213             (switch-to-buffer
 214              (get-buffer-create wl-addrmgr-buffer-name))))
 215       (switch-to-buffer (get-buffer-create wl-addrmgr-buffer-name)))
 216     (set-buffer wl-addrmgr-buffer-name)
 217     (wl-addrmgr-mode)
 218     (unless wl-addrmgr-method
 219       (setq wl-addrmgr-method wl-addrmgr-default-method
 220             wl-addrmgr-method-name (symbol-name wl-addrmgr-default-method)))
 221     (unless wl-addrmgr-sort-key
 222       (setq wl-addrmgr-sort-key wl-addrmgr-default-sort-key))
 223     (unless wl-addrmgr-sort-order
 224       (setq wl-addrmgr-sort-order wl-addrmgr-default-sort-order))
 225     (setq wl-addrmgr-draft-buffer buffer)
 226     (setq wl-addrmgr-list
 227           (wl-addrmgr-merge-entries (wl-addrmgr-list)
 228                                     (wl-addrmgr-pickup-entry-list buffer)))
 229     (wl-addrmgr-draw already-list)
 230     (setq wl-addrmgr-unknown-list already-list)
 231     (wl-addrmgr-goto-top)))
 232
 233 (defun wl-addrmgr-goto-top ()
 234   (interactive)
 235   (goto-char (point-min))
 236   (forward-line 2)
 237   (condition-case nil
 238       (forward-char 4)
 239     (error)))
 240
 241 (defun wl-addrmgr-goto-bottom ()
 242   (interactive)
 243   (goto-char (point-max))
 244   (beginning-of-line)
 245   (forward-char 4))
 246
 247 (defun wl-addrmgr-reload ()
 248   "Reload addresses entries."
 249   (interactive)
 250   (setq wl-addrmgr-list (wl-addrmgr-list 'reload))
 251   (wl-addrmgr-redraw))
 252
 253 (defun wl-addrmgr-redraw ()
 254   "Redraw addresses entries."
 255   (interactive)
 256   (let ((rcpt (wl-addrmgr-mark-check)))
 257     (wl-addrmgr-draw (list (cons 'to (nth 0 rcpt))
 258                            (cons 'cc (nth 1 rcpt))
 259                            (cons 'bcc (nth 2 rcpt)))))
 260   (wl-addrmgr-goto-top))
 261
 262 (defun wl-addrmgr-sort-list (key list order)
 263   (let ((pos (case key
 264                (address 0)
 265                (petname 1)
 266                (realname 2)))
 267         sorted)
 268     (if pos
 269         (progn
 270           (setq sorted (sort list `(lambda (a b) (string< (nth ,pos a)
 271                                                           (nth ,pos b)))))
 272           (if (eq order 'descending)
 273               (nreverse sorted)
 274             sorted))
 275       list)))
 276
 277 (defun wl-addrmgr-insert-line (entry)
 278   (let ((real (nth 2 entry))
 279         (pet  (nth 1 entry))
 280         (addr (nth 0 entry))
 281         beg)
 282     (insert "     ")
 283     (setq beg (point))
 284     (setq real (wl-set-string-width wl-addrmgr-realname-width real))
 285     (put-text-property 0 (length real) 'face
 286                        wl-addrmgr-realname-face
 287                        real)
 288     (setq pet (wl-set-string-width wl-addrmgr-petname-width pet))
 289     (put-text-property 0 (length pet) 'face
 290                        wl-addrmgr-petname-face
 291                        pet)
 292     (setq addr (copy-sequence addr))
 293     (put-text-property 0 (length addr) 'face
 294                        wl-addrmgr-address-face
 295                        addr)
 296     (insert
 297      (wl-set-string-width
 298       (- wl-addrmgr-line-width 4)
 299       (concat real " " pet " " addr)))
 300     (put-text-property beg (point) 'wl-addrmgr-entry entry)))
 301
 302 (defun wl-addrmgr-search-forward-address (address)
 303   "Search forward from point for ADDRESS.
 304 Return nil if no ADDRESS exists."
 305   (let ((pos (point)))
 306     (if (catch 'found
 307             (while (not (eobp))
 308               (if (string= address (car (wl-addrmgr-address-entry)))
 309                   (throw 'found t)
 310                 (forward-line))))
 311         (point)
 312       (goto-char pos)
 313       nil)))
 314
 315 (defun wl-addrmgr-draw (already-list)
 316   "Show recipients mail addresses."
 317   (save-excursion
 318     (let ((buffer-read-only nil)
 319           list field addrs beg real pet addr)
 320       (erase-buffer)
 321       (goto-char (point-min))
 322       (insert
 323        "Mark "
 324        (wl-set-string-width wl-addrmgr-realname-width
 325                             "Realname")
 326        " "
 327        (wl-set-string-width wl-addrmgr-petname-width
 328                             "Petname")
 329        " Address\n")
 330       (insert "---- "
 331               (make-string wl-addrmgr-realname-width ?-)
 332               " "
 333               (make-string wl-addrmgr-petname-width ?-)
 334               " ---------------")
 335       (unless wl-addrmgr-list (insert "\n"))
 336       (dolist (entry (wl-addrmgr-sort-list wl-addrmgr-sort-key
 337                                            (copy-sequence wl-addrmgr-list)
 338                                            wl-addrmgr-sort-order))
 339         (insert "\n")
 340         (wl-addrmgr-insert-line entry))
 341       (set-buffer-modified-p nil)
 342       (while already-list
 343         (setq list (car already-list)
 344               field (car list)
 345               addrs (cdr list))
 346         (while addrs
 347           (goto-char (point-min))
 348           (when (wl-addrmgr-search-forward-address (car addrs))
 349             (wl-addrmgr-mark-write field)
 350             (setcdr list (delq (car addrs) (cdr list))))
 351           (setq addrs (cdr addrs)))
 352         (setq already-list (cdr already-list))))))
 353
 354 (defun wl-addrmgr-next ()
 355   "Move cursor next line."
 356   (interactive)
 357   (end-of-line)
 358   (let ((current (count-lines (point-min) (point)))
 359         first)
 360     (cond
 361      ((<= current 2)
 362       (when (setq first (next-single-property-change (point) 'wl-addrmgr-entry
 363                                                      nil))
 364         (goto-char first)
 365         (beginning-of-line)
 366         (forward-char 4)))
 367      (t
 368       (forward-line)
 369       (beginning-of-line)
 370       (forward-char 4)))))
 371
 372 (defun wl-addrmgr-prev ()
 373   "Move cursor prev line."
 374   (interactive)
 375   (let ((current (count-lines (point-min) (point))))
 376     (cond
 377      ((= current 3)
 378       (beginning-of-line)
 379       (forward-char 4))
 380      ((< current 3)
 381       (goto-char (point-min))
 382       (forward-line 2)
 383       (forward-char 4))
 384      (t
 385       (forward-line -1)
 386       (forward-char 4)))))
 387
 388 (defun wl-addrmgr-quit-yes ()
 389   (let ((draft-buffer wl-addrmgr-draft-buffer))
 390     (if (and draft-buffer
 391              (buffer-live-p draft-buffer)
 392              (null (get-buffer-window draft-buffer 'visible)))
 393         (switch-to-buffer draft-buffer)
 394       (unless (one-window-p)
 395         (delete-window)))
 396     (kill-buffer wl-addrmgr-buffer-name)
 397     (if (and draft-buffer (not (one-window-p)))
 398         (switch-to-buffer-other-window draft-buffer))))
 399
 400 (defun wl-addrmgr-quit ()
 401   "Exit from electric reference mode without inserting reference."
 402   (interactive)
 403   (let ((rcpt (wl-addrmgr-mark-check)))
 404     (if (or (nth 0 rcpt)
 405             (nth 1 rcpt)
 406             (nth 2 rcpt))
 407         (when (y-or-n-p "There is marked address. Quit wl-addrmgr really? ")
 408           (wl-addrmgr-quit-yes))
 409       (wl-addrmgr-quit-yes)))
 410   (message ""))
 411
 412 (defun wl-addrmgr-mark-set-to ()
 413   "Marking To: sign."
 414   (interactive)
 415   (wl-addrmgr-mark-write 'to)
 416   (wl-addrmgr-next))
 417
 418 (defun wl-addrmgr-mark-set-cc ()
 419   "Marking Cc: sign."
 420   (interactive)
 421   (wl-addrmgr-mark-write 'cc)
 422   (wl-addrmgr-next))
 423
 424 (defun wl-addrmgr-mark-set-bcc ()
 425   "Marking Bcc: sign."
 426   (interactive)
 427   (wl-addrmgr-mark-write 'bcc)
 428   (wl-addrmgr-next))
 429
 430 (defun wl-addrmgr-unmark ()
 431   "Erase Marked sign."
 432   (interactive)
 433   (let ((entry (wl-addrmgr-address-entry))
 434         buffer-read-only)
 435     (save-excursion
 436       (beginning-of-line)
 437       (delete-region (point) (progn (end-of-line)(point)))
 438       (wl-addrmgr-insert-line entry))
 439     (set-buffer-modified-p nil)
 440     (wl-addrmgr-next)))
 441
 442 (defun wl-addrmgr-sort ()
 443   "Sort address entry."
 444   (interactive)
 445   (setq wl-addrmgr-sort-key (intern
 446                              (completing-read
 447                               (format "Sort By (%s): "
 448                                       (symbol-name wl-addrmgr-sort-key))
 449                               '(("address")("realname")("petname")("none"))
 450                               nil t nil nil
 451                               (symbol-name wl-addrmgr-sort-key))))
 452   (if (eq wl-addrmgr-sort-key 'none)
 453       (wl-addrmgr-reload)
 454     (setq wl-addrmgr-sort-order (intern
 455                                  (completing-read
 456                                   (format "Sort Order (%s): "
 457                                           (symbol-name wl-addrmgr-sort-order))
 458                                   '(("ascending") ("descending"))
 459                                   nil t nil nil
 460                                   (symbol-name wl-addrmgr-sort-order))))
 461     (wl-addrmgr-redraw)))
 462
 463 ;;; Backend methods.
 464 (defun wl-addrmgr-method-call (method &rest args)
 465   (apply (intern (concat "wl-addrmgr-"
 466                          (symbol-name wl-addrmgr-method)
 467                          "-" (symbol-name method)))
 468          args))
 469
 470 (defun wl-addrmgr-change-method ()
 471   (interactive)
 472   (setq wl-addrmgr-method (intern
 473                            (setq wl-addrmgr-method-name
 474                                  (completing-read
 475                                   (format "Method (%s): "
 476                                           (symbol-name wl-addrmgr-method))
 477                                   (mapcar (lambda (method)
 478                                             (list (symbol-name method)))
 479                                           wl-addrmgr-method-list)
 480                                   nil t nil nil
 481                                   (symbol-name wl-addrmgr-method)))))
 482   (wl-addrmgr-redraw))
 483
 484 (defun wl-addrmgr-list (&optional reload)
 485   "List address entries."
 486   (wl-addrmgr-method-call 'list reload))
 487
 488 (defun wl-addrmgr-add ()
 489   "Add address entry."
 490   (interactive)
 491   (let ((entry (wl-addrmgr-method-call 'add)))
 492     (if (eq wl-addrmgr-sort-key 'none)
 493         (wl-addrmgr-reload)
 494       (setq wl-addrmgr-list (cons entry wl-addrmgr-list))
 495       (wl-addrmgr-redraw))
 496     (message "Added `%s'." (wl-string (car entry)))))
 497
 498 (defun wl-addrmgr-delete ()
 499   "Delete address entry."
 500   (interactive)
 501   (let ((addr (wl-string (car (wl-addrmgr-address-entry))))
 502         lines)
 503     (when (and addr
 504                (y-or-n-p (format "Delete '%s'? " addr)))
 505       (setq lines (count-lines (point-min) (point)))
 506       (wl-addrmgr-method-call 'delete addr)
 507       (setq wl-addrmgr-list (delq (assoc addr wl-addrmgr-list)
 508                                   wl-addrmgr-list))
 509       (wl-addrmgr-redraw)
 510       (forward-line (- lines 2))
 511       (message "Deleted `%s'." addr))))
 512
 513 (defun wl-addrmgr-edit ()
 514   "Edit address entry."
 515   (interactive)
 516   (let ((orig (wl-addrmgr-address-entry))
 517         entry lines)
 518     (setq entry (wl-addrmgr-method-call 'edit (wl-string (car orig))))
 519     (setq lines (count-lines (point-min) (point)))
 520     (if (eq wl-addrmgr-sort-key 'none)
 521         (wl-addrmgr-reload)
 522       (setq wl-addrmgr-list (delq (assoc (car orig) wl-addrmgr-list)
 523                                   wl-addrmgr-list)
 524             wl-addrmgr-list (cons entry wl-addrmgr-list))
 525       (wl-addrmgr-redraw))
 526     (forward-line (- lines 1))
 527     (message "Modified `%s'." (wl-string (car entry)))))
 528
 529 ;;; local address book implementation.
 530 (defun wl-addrmgr-local-list (reload)
 531   (if (or (null wl-address-list) reload)
 532       (wl-address-init))
 533   (copy-sequence wl-address-list))
 534
 535 (defun wl-addrmgr-local-add ()
 536   (wl-address-add-or-change nil nil 'addr-too))
 537
 538 (defun wl-addrmgr-local-edit (address)
 539   (wl-address-add-or-change address nil 'addr-too))
 540
 541 (defun wl-addrmgr-local-delete (address)
 542   (wl-address-delete address))
 543
 544 ;;; LDAP implementation (Implement Me)
 545
 546 ;;; Operations.
 547
 548 (defun wl-addrmgr-address-entry ()
 549   (save-excursion
 550     (end-of-line)
 551     (get-text-property (previous-single-property-change
 552                         (point) 'wl-addrmgr-entry nil
 553                         (progn
 554                           (beginning-of-line)
 555                           (point)))
 556                        'wl-addrmgr-entry)))
 557
 558 (defun wl-addrmgr-mark-write (&optional mark)
 559   "Set MARK to the current address entry."
 560   (save-excursion
 561     (end-of-line)
 562     (unless (< (count-lines (point-min) (point)) 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)) ? ))
 572         (beginning-of-line)
 573         (setq beg (point))
 574         (setq end (progn (end-of-line)
 575                          (point)))
 576         (put-text-property beg end 'face nil)
 577         (wl-highlight-message beg end nil))
 578       (set-buffer-modified-p nil)
 579       (beginning-of-line)
 580       (forward-char 4))))
 581
 582 (defun wl-addrmgr-apply ()
 583   (interactive)
 584   (let ((rcpt (wl-addrmgr-mark-check 'full)))
 585     (when (or (or (nth 0 rcpt)
 586                   (nth 1 rcpt)
 587                   (nth 2 rcpt))
 588               (or (cdr (assq 'to wl-addrmgr-unknown-list))
 589                   (cdr (assq 'cc wl-addrmgr-unknown-list))
 590                   (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 591       (wl-addrmgr-apply-exec (wl-addrmgr-mark-check 'full)))
 592     (wl-addrmgr-quit-yes)))
 593
 594 (defun wl-addrmgr-mark-check (&optional full)
 595   "Return list of recipients (TO CC BCC)."
 596   (save-excursion                       ; save cursor POINT
 597     (goto-char (point-min))
 598     (forward-line 2)
 599     (let (to-list cc-list bcc-list mark addr realname)
 600       (while (and (not (eobp))
 601                   (re-search-forward "^\\([^ ]+:\\) " nil t))
 602         (setq mark (match-string 1))
 603         (setq addr (car (wl-addrmgr-address-entry)))
 604         (setq realname (nth 2 (wl-addrmgr-address-entry)))
 605         (cond
 606          ((string= mark "To:")
 607           (setq to-list (cons
 608                          (if (and full
 609                                   (not (or (string= realname "")
 610                                            (string-match ".*:.*;$" addr))))
 611                              (concat
 612                               (wl-address-quote-specials realname)
 613                               " <" addr">")
 614                            addr)
 615                          to-list)))
 616          ((string= mark "Cc:")
 617           (setq cc-list (cons
 618                          (if (and full
 619                                   (not (or (string= realname "")
 620                                            (string-match ".*:.*;$" addr))))
 621                              (concat
 622                               (wl-address-quote-specials realname)
 623                               " <" addr">")
 624                            addr)
 625                          cc-list)))
 626          ((string= mark "Bcc:")
 627           (setq bcc-list (cons
 628                           (if (and full
 629                                    (not (or (string= realname "")
 630                                             (string-match ".*:.*;$" addr))))
 631                               (concat
 632                                (wl-address-quote-specials realname)
 633                                " <" addr">")
 634                             addr)
 635                           bcc-list)))))
 636       (list to-list cc-list bcc-list))))
 637
 638 (defun wl-addrmgr-apply-exec (rcpt)
 639   (let ((to (nconc (nth 0 rcpt) (cdr (assq 'to wl-addrmgr-unknown-list))))
 640         (cc (nconc (nth 1 rcpt) (cdr (assq 'cc wl-addrmgr-unknown-list))))
 641         (bcc (nconc (nth 2 rcpt) (cdr (assq 'bcc wl-addrmgr-unknown-list))))
 642         from clist)
 643     (setq clist (list (cons "Bcc" (if bcc (mapconcat 'identity bcc ",\n\t")))
 644                       (cons "Cc" (if cc (mapconcat 'identity cc ",\n\t")))
 645                       (cons "To" (if to (mapconcat 'identity to ",\n\t")))))
 646     (when (or (null wl-addrmgr-draft-buffer)
 647               (not (buffer-live-p wl-addrmgr-draft-buffer)))
 648       (setq wl-addrmgr-draft-buffer (save-window-excursion
 649                                       (call-interactively 'wl-draft)
 650                                       (current-buffer))))
 651     (with-current-buffer wl-addrmgr-draft-buffer
 652       (setq from (std11-field-body "From"))
 653       (if from
 654           (setq clist (append clist (list (cons "From" from)))))
 655       (wl-addrmgr-mark-exec-sub clist))))
 656
 657 (defun wl-addrmgr-replace-field (field content)
 658   "Insert FIELD with CONTENT to the top of the header fields."
 659   (save-excursion
 660     (save-restriction
 661       (let ((case-fold-search t)
 662             (inhibit-read-only t) ;; added by teranisi.
 663             beg)
 664         (std11-narrow-to-header mail-header-separator)
 665         (goto-char (point-min))
 666         (while (re-search-forward (concat "^" (regexp-quote field) ":") nil t)
 667           ;; delete field
 668           (progn
 669             (save-excursion
 670               (beginning-of-line)
 671               (setq beg (point)))
 672             (re-search-forward "^[^ \t]" nil 'move)
 673             (beginning-of-line)
 674             (delete-region beg (point))))
 675         (when content
 676           ;; add field to top.
 677           (goto-char (point-min))
 678           (insert (concat field ": " content "\n")))))))
 679
 680 (defun wl-addrmgr-mark-exec-sub (list)
 681   (dolist (pair list)
 682     (wl-addrmgr-replace-field (car pair) (cdr pair)))
 683   ;; from wl-template.el
 684   ;; rehighlight
 685   (if wl-highlight-body-too
 686       (let ((beg (point-min))
 687             (end (point-max)))
 688         (put-text-property beg end 'face nil)
 689         (wl-highlight-message beg end t))))
 690
 691 (require 'product)
 692 (product-provide (provide 'wl-addrmgr) (require 'wl-version))
 693
 694 ;;; wl-addrmgr.el ends here