From d2c6e952439f4bd006559796cb5e51a133b5888c Mon Sep 17 00:00:00 2001 From: teranisi Date: Mon, 2 Apr 2001 11:16:23 +0000 Subject: [PATCH] * wl-vars.el (wl-biff-unnotify-hook): New variable. * wl-util.el (wl-biff-notify): Run `wl-biff-unnotify-hook' when biff notification is removed. * utils/bbdb-wl.el: Applied patch from Hiroya Murata for bbdb 2.33 (X-Mail-Count: 07190, 07195 in the ML); Added workaround for older version of bbdb. --- utils/bbdb-wl.el | 219 +++++++++++++++++++++++++++++++++++++++--------------- wl/ChangeLog | 5 ++ wl/wl-util.el | 2 + wl/wl-vars.el | 2 + 4 files changed, 168 insertions(+), 60 deletions(-) diff --git a/utils/bbdb-wl.el b/utils/bbdb-wl.el index c7be695..8f99292 100644 --- a/utils/bbdb-wl.el +++ b/utils/bbdb-wl.el @@ -24,6 +24,7 @@ (require 'wl-message) (require 'wl-draft) (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)))) @@ -124,11 +125,62 @@ from-str) string))) +(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'." + (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) + (while headers + (setq header (std11-fetch-field (car headers))) + (when header + (setq structures (std11-parse-addresses-string + (std11-unfold-string header))) + (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)))) + 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 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-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 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and the user confirms the creation." + (let* ((bbdb-get-only-first-address-p t) + (records (bbdb-wl-update-records offer-to-create))) + (if (and records (listp records)) + (car records) + records))) + +(defun bbdb-wl-update-records (&optional offer-to-create) + "Returns the records corresponding to the current WL message, +creating or modifying it as necessary. A record will be created if +bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and +the user confirms the creation." (save-excursion (if bbdb-use-pop-up (bbdb-wl-pop-up-bbdb-buffer offer-to-create) @@ -142,33 +194,43 @@ the user confirms the creation." (intern (format "%s-%d" wl-current-summary-buffer - wl-message-buffer-cur-number))))) - (or (bbdb-message-cache-lookup key nil) - (and key - (let* ((from (or (std11-field-body "From") "")) - (addr (and from - (nth 1 (std11-extract-address-components - from))))) - (if (or (null from) - (null addr) - (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 - default-enable-multibyte-characters) - (setq from (eword-decode-string - (decode-mime-charset-string - from - wl-mime-charset)))) - (if from - (bbdb-encache-message - key - (bbdb-annotate-message-sender - from t - (or (bbdb-invoke-hook-for-value - bbdb/mail-auto-create-p) - offer-to-create) - offer-to-create)))))))))) + wl-message-buffer-cur-number)))) + record) + (or (progn (setq record (bbdb-message-cache-lookup key)) + (if (listp record) (nth 1 record) record)) + (static-if (not (fboundp 'bbdb-update-records)) + (let* ((from (or (std11-field-body "From") "")) + (addr (and from + (nth 1 (std11-extract-address-components + from))))) + (if (or (null from) + (null addr) + (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 + default-enable-multibyte-characters) + (setq from (eword-decode-string + (decode-mime-charset-string + from + wl-mime-charset)))) + (if from + (bbdb-encache-message + key + (bbdb-annotate-message-sender + from t + (or (bbdb-invoke-hook-for-value + bbdb/mail-auto-create-p) + offer-to-create) + offer-to-create)))) + (bbdb-encache-message + key + (bbdb-update-records (bbdb-wl-get-addresses + bbdb-get-only-first-address-p) + (or (bbdb-invoke-hook-for-value + bbdb/mail-auto-create-p) + offer-to-create) + offer-to-create)))))))) (defun bbdb-wl-annotate-sender (string) "Add a line to the end of the Notes field of the BBDB record @@ -183,7 +245,7 @@ corresponding to the sender of this message." "Edit the notes field or (with a prefix arg) a user-defined field of the BBDB record corresponding to the sender of this message." (interactive "P") - (wl-summary-redisplay) + (wl-summary-set-message-buffer-or-redisplay) (set-buffer (wl-message-get-original-buffer)) (let ((record (or (bbdb-wl-update-record t) (error "")))) (bbdb-display-records (list record)) @@ -191,23 +253,59 @@ of the BBDB record corresponding to the sender of this message." (bbdb-record-edit-property record nil t) (bbdb-record-edit-notes record t)))) -(defun bbdb-wl-show-sender () +(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." (interactive) (wl-summary-set-message-buffer-or-redisplay) (set-buffer (wl-message-get-original-buffer)) - (let ((record (bbdb-wl-update-record t)) - bbdb-win) - (if record + (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) + (setq records (bbdb-wl-update-records t)) + (if records (progn (bbdb-wl-pop-up-bbdb-buffer) - (bbdb-display-records (list record))) - (error "Unperson")) + (bbdb-display-records (if (listp records) records + (list records)))) + (bbdb-undisplay-records)) (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name))) (and bbdb-win - (select-window bbdb-win)))) + (select-window bbdb-win)) + records)) +(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)) + +(defun bbdb-wl-show-sender (&optional show-recipients) + "Display the contents of the BBDB for the senders of this message. +With a prefix argument show the recipients instead, +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))))) (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create) "Make the *BBDB* buffer be displayed along with the WL window(s), @@ -242,12 +340,15 @@ 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 ((record (bbdb-wl-update-record offer-to-create)) + (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))) - (bbdb-display-records (if record (list record) nil)) + (bbdb-display-records (if (listp records) records + (list records))) (set-buffer b) - record))) + records))) (defun bbdb-wl-send-mail-internal (&optional to subj records) (unwind-protect @@ -256,29 +357,27 @@ displaying the record corresponding to the sender of the current message." ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb. ;;; -(if (and (string< bbdb-version "1.58") - ;; (not (fboundp 'bbdb-extract-field-value) ; defined as autoload - (not (fboundp 'bbdb-header-start))) +(and (not (fboundp 'bbdb-wl-extract-field-value-internal)) +;;; (not (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb (progn - (load "bbdb-hooks") - (require 'bbdb-hooks))) - -(static-cond ((fboundp 'tm:bbdb-extract-field-value) - (defun bbdb-wl-extract-field-value-internal (field) - (funcall (symbol-function 'tm:bbdb-extract-field-value) - field))) - (t - (defun bbdb-wl-extract-field-value-internal (field) - (funcall (symbol-function 'bbdb-extract-field-value) - field)))) - -(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))))) + (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) diff --git a/wl/ChangeLog b/wl/ChangeLog index c361321..537c986 100644 --- a/wl/ChangeLog +++ b/wl/ChangeLog @@ -1,5 +1,10 @@ 2001-04-02 Yuuichi Teranishi + * wl-vars.el (wl-biff-unnotify-hook): New variable. + + * wl-util.el (wl-biff-notify): Run `wl-biff-unnotify-hook' when + biff notification is removed. + * wl.el (wl): Changed position of `elmo-init'. * wl-draft.el (wl-default-draft-cite): Use date field diff --git a/wl/wl-util.el b/wl/wl-util.el index 486b742..4bbab77 100644 --- a/wl/wl-util.el +++ b/wl/wl-util.el @@ -788,6 +788,8 @@ This function is imported from Emacs 20.7." (defsubst wl-biff-notify (new-mails notify-minibuf) (when (and (not wl-modeline-biff-status) (> new-mails 0)) (run-hooks 'wl-biff-notify-hook)) + (when (and wl-modeline-biff-status (eq new-mails 0)) + (run-hooks 'wl-biff-unnotify-hook)) (setq wl-modeline-biff-status (> new-mails 0)) (force-mode-line-update t) (when notify-minibuf diff --git a/wl/wl-vars.el b/wl/wl-vars.el index 1523a47..bc3cb0d 100644 --- a/wl/wl-vars.el +++ b/wl/wl-vars.el @@ -470,6 +470,8 @@ reasons of system internal to accord facilities for the Emacs variants.") "A hook called when suspend wanderlust.") (defvar wl-biff-notify-hook nil "A hook called when a biff-notification is invoked.") +(defvar wl-biff-unnotify-hook nil + "A hook called when a biff-notification is removed.") (defvar wl-auto-check-folder-pre-hook nil "A hook called before auto check folders.") (defvar wl-auto-check-folder-hook nil -- 1.7.10.4