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