X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=utils%2Fbbdb-wl.el;h=b40e4c24550e6f9da90517214e9be0ba8a68ab12;hb=25c974de7a2220f976bc6a99172cc60d79d6b5b7;hp=b6f0c7d3288c31c6379ba32c226bb9a12c0f8863;hpb=8b003dd16e3d4a1f0d29b5fcd0f57a2ee294f967;p=elisp%2Fwanderlust.git diff --git a/utils/bbdb-wl.el b/utils/bbdb-wl.el index b6f0c7d..b40e4c2 100644 --- a/utils/bbdb-wl.el +++ b/utils/bbdb-wl.el @@ -8,7 +8,7 @@ ;;; Commentary: ;; ;; Insert the following lines in your ~/.wl -;; +;; ;; (require 'bbdb-wl) ;; (bbdb-wl-setup) @@ -26,18 +26,31 @@ (require 'wl-address) (require 'bbdb-com) (defvar bbdb-pop-up-elided-display nil)) -;; (or (fboundp 'bbdb-wl-extract-field-value-internal) -;; (defun bbdb-wl-extract-field-value-internal (field)))) + (require 'bbdb) (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) @@ -54,25 +67,41 @@ (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) (if (setq bbdb-buf (get-buffer bbdb-buffer-name)) (kill-buffer bbdb-buf))) - (bbdb-save-db t)) + (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) @@ -106,7 +135,7 @@ (switch-to-buffer (get-buffer-create bbdb-buffer-name))))))) (defun bbdb-wl-get-petname (from) - "For `wl-summary-get-petname-func'." + "For `wl-summary-get-petname-function'." (let* ((address (wl-address-header-extract-address from)) (record (bbdb-search-simple nil address))) (and record @@ -114,7 +143,7 @@ (car (bbdb-record-name record)))))) (defun bbdb-wl-from-func (string) - "A candidate From field STRING. For `wl-summary-from-func'." + "A candidate From field STRING. For `wl-summary-from-function'." (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address string))) first-name last-name from-str) @@ -132,10 +161,11 @@ from-str) string))) -(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) @@ -157,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 @@ -260,18 +348,6 @@ of the BBDB record corresponding to the sender of this message." (bbdb-record-edit-property record nil t) (bbdb-record-edit-notes record t)))) -(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-show-records (&optional headers) "Display the contents of the BBDB for the sender of this message. This buffer will be in `bbdb-mode', with associated keybindings." @@ -279,10 +355,10 @@ This buffer will be in `bbdb-mode', with associated keybindings." (wl-summary-set-message-buffer-or-redisplay) (set-buffer (wl-message-get-original-buffer)) (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers)) - (bbdb-update-records-mode 'annotating) - (bbdb-message-cache nil) - (bbdb-user-mail-names nil) - records bbdb-win) + (bbdb-update-records-mode 'annotating) + (bbdb-message-cache nil) + (bbdb-user-mail-names nil) + records bbdb-win) (setq records (bbdb-wl-update-records t)) (if records (progn @@ -295,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. @@ -307,12 +396,13 @@ with two prefix arguments show all records. This buffer will be in `bbdb-mode', with associated keybindings." (interactive "p") (cond ((= 4 show-recipients) - (bbdb-wl-show-all-recipients)) - ((= 16 show-recipients) - (bbdb-wl-show-records)) - (t - (if (null (bbdb-wl-show-records bbdb-get-addresses-from-headers)) - (bbdb-wl-show-all-recipients))))) + (bbdb-wl-show-all-recipients)) + ((= 16 show-recipients) + (bbdb-wl-show-records)) + (t + (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) "Make the *BBDB* buffer be displayed along with the WL window(s), @@ -347,11 +437,18 @@ displaying the record corresponding to the sender of the current message." (let ((bbdb-gag-messages t) (bbdb-use-pop-up nil) (bbdb-electric-p nil)) - (let ((records (static-if (fboundp 'bbdb-update-records) - (bbdb-wl-update-records offer-to-create) - (bbdb-wl-update-record offer-to-create))) - (bbdb-elided-display (bbdb-pop-up-elided-display)) - (b (current-buffer))) + (let* ((records (static-if (fboundp 'bbdb-update-records) + (bbdb-wl-update-records offer-to-create) + (bbdb-wl-update-record offer-to-create))) + ;; BBDB versions v2.33 and later. + (bbdb-display-layout + (cond ((boundp 'bbdb-pop-up-display-layout) + (symbol-value 'bbdb-pop-up-display-layout)) + ((boundp 'bbdb-pop-up-elided-display) + (symbol-value 'bbdb-pop-up-elided-display)))) + ;; BBDB versions prior to v2.33, + (bbdb-elided-display bbdb-display-layout) + (b (current-buffer))) (bbdb-display-records (if (listp records) records (list records))) (set-buffer b) @@ -364,27 +461,28 @@ displaying the record corresponding to the sender of the current message." ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb. ;;; -(and (not (fboundp 'bbdb-wl-extract-field-value-internal)) -;;; (not (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb - (progn - (if (and (string< bbdb-version "1.58") - ;; (not (fboundp 'bbdb-extract-field-value) ; defined as autoload - (not (fboundp 'bbdb-header-start))) - (load "bbdb-hooks") - (require 'bbdb-hooks)) - (fset 'bbdb-wl-extract-field-value-internal - (cond - ((fboundp 'tm:bbdb-extract-field-value) - (symbol-function 'tm:bbdb-extract-field-value)) - (t (symbol-function 'bbdb-extract-field-value)))) - (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 - default-enable-multibyte-characters) - (and value - (eword-decode-string value))))) - )) +(eval-and-compile + (if (fboundp 'bbdb-wl-extract-field-value-internal) +;;(if (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb + nil + (if (and (string< bbdb-version "1.58") + ;;(not (fboundp 'bbdb-extract-field-value) ;; defined as autoload + (not (fboundp 'bbdb-header-start))) + (load "bbdb-hooks") + (require 'bbdb-hooks)) + (fset 'bbdb-wl-extract-field-value-internal + (cond + ((fboundp 'tm:bbdb-extract-field-value) + (symbol-function 'tm:bbdb-extract-field-value)) + (t (symbol-function 'bbdb-extract-field-value)))) + (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 + default-enable-multibyte-characters) + (and value + (eword-decode-string value))))) + )) (provide 'bbdb-wl)