(defvar bbdb-wl-get-update-record-hook nil)
(defvar bbdb-wl-folder-regexp nil)
+(defvar bbdb-wl-ignore-folder-regexp nil)
+(defvar bbdb-wl-canonicalize-full-name-function
+ #'bbdb-wl-canonicalize-spaces-and-dots
+ "Way to canonicalize full name.")
+
+(defun bbdb-wl-canonicalize-spaces-and-dots (string)
+ (while (and string (string-match " +\\|[\f\t\n\r\v]+\\|\\." string))
+ (setq string (replace-match " " nil t string)))
+ (and string (string-match "^ " string)
+ (setq string (replace-match "" nil t string)))
+ string)
+
+;;;###autoload
(defun bbdb-wl-setup ()
(add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
(add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
(add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
(add-hook 'wl-exit-hook 'bbdb-wl-exit)
+ (add-hook 'wl-save-hook 'bbdb-offer-save)
(add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
(add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
(add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
(function
(lambda ()
;;; (local-set-key "\M-\t" 'bbdb-complete-name)
- (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)
- ))))
+ (define-key (current-local-map) "\M-\t" 'bbdb-complete-name))))
+ (require 'bbdb)
+ (bbdb-initialize)
+
+ (if (not (boundp 'bbdb-get-addresses-from-headers))
+ (defvar bbdb-get-addresses-from-headers
+ '("From" "Resent-From" "Reply-To")))
+
+ (if (not (boundp 'bbdb-get-addresses-to-headers))
+ (defvar bbdb-get-addresses-to-headers
+ '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
+
+ (if (not (boundp 'bbdb-get-addresses-headers))
+ (defvar bbdb-get-addresses-headers
+ (append bbdb-get-addresses-from-headers
+ bbdb-get-addresses-to-headers))))
(defun bbdb-wl-exit ()
(let (bbdb-buf)
(bbdb-offer-save))
(defun bbdb-wl-get-update-record ()
- (if (or (null bbdb-wl-folder-regexp)
- (string-match
- bbdb-wl-folder-regexp
- (with-current-buffer
- wl-message-buffer-cur-summary-buffer
- (wl-summary-buffer-folder-name))))
- (with-current-buffer (wl-message-get-original-buffer)
- (bbdb-wl-update-record)
- (run-hooks 'bbdb-wl-get-update-record-hook))))
+ (let ((folder-name (with-current-buffer
+ wl-message-buffer-cur-summary-buffer
+ (wl-summary-buffer-folder-name))))
+ (if (and (or (null bbdb-wl-folder-regexp)
+ (string-match bbdb-wl-folder-regexp folder-name))
+ (not (and bbdb-wl-ignore-folder-regexp
+ (string-match bbdb-wl-ignore-folder-regexp
+ folder-name))))
+ (with-current-buffer (wl-message-get-original-buffer)
+ (bbdb-wl-update-record)
+ (run-hooks 'bbdb-wl-get-update-record-hook)))))
(defun bbdb-wl-hide-bbdb-buffer ()
(let (bbdb-buf bbdb-win)
from-str)
string)))
-(if (not (boundp 'bbdb-get-addresses-from-headers))
- (defvar bbdb-get-addresses-from-headers
- '("From" "Resent-From" "Reply-To")))
-
-(if (not (boundp 'bbdb-get-addresses-to-headers))
- (defvar bbdb-get-addresses-to-headers
- '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
-
-(if (not (boundp 'bbdb-get-addresses-headers))
- (defvar bbdb-get-addresses-headers
- (append bbdb-get-addresses-from-headers bbdb-get-addresses-to-headers)))
-
-(defun bbdb-wl-get-addresses (&optional only-first-address)
+(defun bbdb-wl-get-addresses-1 (&optional only-first-address)
"Return real name and email address of sender respectively recipients.
If an address matches `bbdb-user-mail-names' it will be ignored.
-The headers to search can be configured by `bbdb-get-addresses-headers'."
+The headers to search can be configured by `bbdb-get-addresses-headers'.
+For BBDB 2.33 or earlier."
(save-excursion
(save-restriction
(std11-narrow-to-header)
(setq fn (std11-full-name-string structure)
fn (and fn
(with-temp-buffer ; to keep raw buffer unibyte.
- (elmo-set-buffer-multibyte
+ (set-buffer-multibyte
default-enable-multibyte-characters)
(eword-decode-string
(decode-mime-charset-string
fn wl-mime-charset))))
+ fn (funcall bbdb-wl-canonicalize-full-name-function fn)
ad (std11-address-string structure))
-
;; ignore uninteresting addresses, this is kinda gross!
(when (or (not (stringp uninteresting-senders))
- (not (or
- (and fn (string-match uninteresting-senders fn))
- (and ad (string-match uninteresting-senders ad)))))
+ (not
+ (or
+ (and fn (string-match uninteresting-senders fn))
+ (and ad (string-match uninteresting-senders ad)))))
(add-to-list 'addrlist (list fn ad)))
-
(if (and only-first-address addrlist)
(setq structures nil headers nil)
(setq structures (cdr structures)))))
(setq headers (cdr headers)))
(nreverse addrlist)))))
+(defun bbdb-wl-get-addresses-2 (&optional only-first-address)
+ "Return real name and email address of sender respectively recipients.
+If an address matches `bbdb-user-mail-names' it will be ignored.
+The headers to search can be configured by `bbdb-get-addresses-headers'.
+For BBDB 2.34 or later."
+ (save-excursion
+ (save-restriction
+ (std11-narrow-to-header)
+ (let ((headers bbdb-get-addresses-headers)
+ (uninteresting-senders bbdb-user-mail-names)
+ addrlist header structures structure fn ad
+ header-type header-fields header-content)
+ (while headers
+ (setq header-type (caar headers)
+ header-fields (cdar headers))
+ (while header-fields
+ (setq header-content (std11-fetch-field (car header-fields)))
+ (when header-content
+ (setq structures (std11-parse-addresses-string
+ (std11-unfold-string header-content)))
+ (while (and (setq structure (car structures))
+ (eq (car structure) 'mailbox))
+ (setq fn (std11-full-name-string structure)
+ fn (and fn
+ (with-temp-buffer ; to keep raw buffer unibyte.
+ (set-buffer-multibyte
+ default-enable-multibyte-characters)
+ (eword-decode-string
+ (decode-mime-charset-string
+ fn wl-mime-charset))))
+ fn (funcall bbdb-wl-canonicalize-full-name-function fn)
+ ad (std11-address-string structure))
+ ;; ignore uninteresting addresses, this is kinda gross!
+ (when (or (not (stringp uninteresting-senders))
+ (not
+ (or
+ (and fn
+ (string-match uninteresting-senders fn))
+ (and ad
+ (string-match uninteresting-senders ad)))))
+ (add-to-list 'addrlist (list header-type
+ (car header-fields)
+ (list fn ad))))
+ (if (and only-first-address addrlist)
+ (setq structures nil headers nil)
+ (setq structures (cdr structures)))))
+ (setq header-fields (cdr header-fields)))
+ (setq headers (cdr headers)))
+ (nreverse addrlist)))))
+
+(defun bbdb-wl-get-addresses (&optional only-first-address)
+ "Return real name and email address of sender respectively recipients.
+If an address matches `bbdb-user-mail-names' it will be ignored.
+The headers to search can be configured by `bbdb-get-addresses-headers'."
+ (if (string< bbdb-version "2.34")
+ (bbdb-wl-get-addresses-1)
+ (bbdb-wl-get-addresses-2)))
+
(defun bbdb-wl-update-record (&optional offer-to-create)
"Returns the record corresponding to the current WL message,
creating or modifying it as necessary. A record will be created if
(string-match (bbdb-user-mail-names) addr))
(setq from (or (std11-field-body "To") from)))
(with-temp-buffer ; to keep raw buffer unibyte.
- (elmo-set-buffer-multibyte
+ (set-buffer-multibyte
default-enable-multibyte-characters)
(setq from (eword-decode-string
(decode-mime-charset-string
(select-window bbdb-win))
records))
+(defun bbdb-wl-address-headers-spec (address-class)
+ "Return address headers structure for ADDRESS-CLASS."
+ (if (string< bbdb-version "2.34")
+ (cond
+ ((eq address-class 'recipients)
+ bbdb-get-addresses-to-headers)
+ ((eq address-class 'authors)
+ bbdb-get-addresses-from-headers)
+ (t
+ (append bbdb-get-addresses-to-headers
+ bbdb-get-addresses-from-headers)))
+ (list (assoc address-class bbdb-get-addresses-headers))))
+
(defun bbdb-wl-show-all-recipients ()
"Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
(interactive)
- (bbdb-wl-show-records bbdb-get-addresses-to-headers))
+ (bbdb-wl-show-records (bbdb-wl-address-headers-spec 'recipients)))
(defun bbdb-wl-show-sender (&optional show-recipients)
"Display the contents of the BBDB for the senders of this message.
((= 16 show-recipients)
(bbdb-wl-show-records))
(t
- (if (null (bbdb-wl-show-records bbdb-get-addresses-from-headers))
+ (if (null (bbdb-wl-show-records
+ (bbdb-wl-address-headers-spec 'authors)))
(bbdb-wl-show-all-recipients)))))
(defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
(defun bbdb-extract-field-value (field)
(let ((value (bbdb-wl-extract-field-value-internal field)))
(with-temp-buffer ; to keep raw buffer unibyte.
- (elmo-set-buffer-multibyte
+ (set-buffer-multibyte
default-enable-multibyte-characters)
(and value
(eword-decode-string value)))))
projects / elisp / wanderlust.git / blobdiff