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