X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=utils%2Fbbdb-wl.el;h=b40e4c24550e6f9da90517214e9be0ba8a68ab12;hb=fb40159a1fc3d4fb1400f8fe3befb1056bc75b8c;hp=cfabd0c50a8cea69a770a1b6d9cc29ddd8c4b988;hpb=5ad375c41b2bc6987c19a0e95bd30cb92f13eb42;p=elisp%2Fwanderlust.git diff --git a/utils/bbdb-wl.el b/utils/bbdb-wl.el index cfabd0c..b40e4c2 100644 --- a/utils/bbdb-wl.el +++ b/utils/bbdb-wl.el @@ -31,6 +31,18 @@ (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 () @@ -38,6 +50,7 @@ (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) @@ -55,13 +68,21 @@ (lambda () ;;; (local-set-key "\M-\t" 'bbdb-complete-name) (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)))) - ;; BBDB 2.00.06 or earlier: - ;; auto-autoloads.el includes (provide 'bbdb-autoloads) - ;; Don't exist bbdb-autoloads.el - (when (and (not (featurep 'bbdb-autoloads)) - (module-installed-p 'bbdb-autoloads)) - ;; BBDB 2.20: bbdb-autoloads.el NOT includes (provide 'bbdb-autoloads) - (load "bbdb-autoloads"))) + (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) @@ -70,15 +91,17 @@ (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) @@ -138,22 +161,11 @@ 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) @@ -175,21 +187,79 @@ The headers to search can be configured by `bbdb-get-addresses-headers'." (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. + (elmo-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 @@ -301,10 +371,23 @@ This buffer will be in `bbdb-mode', with associated keybindings." (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. @@ -317,7 +400,8 @@ This buffer will be in `bbdb-mode', with associated keybindings." ((= 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)