utils/bbdb-wl.el

   1 ;;; bbdb-wl.el -- BBDB interface to Wanderlust
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, news, database
   7
   8 ;;; Commentary:
   9 ;;
  10 ;;  Insert the following lines in your ~/.wl
  11 ;;
  12 ;;  (require 'bbdb-wl)
  13 ;;  (bbdb-wl-setup)
  14
  15 ;;; Code:
  16 ;;
  17
  18 ;; bbdb setup.
  19 (eval-when-compile
  20   (require 'mime-setup)
  21   (require 'elmo-vars)
  22   (require 'elmo-util)
  23   (require 'wl-summary)
  24   (require 'wl-message)
  25   (require 'wl-draft)
  26   (require 'wl-address)
  27   (require 'bbdb-com)
  28   (defvar bbdb-pop-up-elided-display nil))
  29
  30 (require 'bbdb)
  31
  32 (defvar bbdb-wl-get-update-record-hook nil)
  33 (defvar bbdb-wl-folder-regexp nil)
  34
  35 (defun bbdb-wl-setup ()
  36   (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
  37   (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
  38   (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
  39   (add-hook 'wl-exit-hook 'bbdb-wl-exit)
  40   (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
  41   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
  42   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
  43   (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
  44             'bbdb-wl-show-bbdb-buffer)
  45   (add-hook 'wl-summary-mode-hook
  46             (function
  47              (lambda ()
  48                (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
  49                (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
  50   (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
  51   (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
  52   (add-hook 'wl-mail-setup-hook
  53             (function
  54              (lambda ()
  55 ;;;            (local-set-key "\M-\t" 'bbdb-complete-name)
  56                (define-key (current-local-map) "\M-\t" 'bbdb-complete-name))))
  57   ;; BBDB 2.00.06 or earlier:
  58   ;;  auto-autoloads.el includes (provide 'bbdb-autoloads)
  59   ;;  Don't exist bbdb-autoloads.el
  60   (when (and (not (featurep 'bbdb-autoloads))
  61              (module-installed-p 'bbdb-autoloads))
  62     ;; BBDB 2.20: bbdb-autoloads.el NOT includes (provide 'bbdb-autoloads)
  63     (load "bbdb-autoloads")))
  64
  65 (defun bbdb-wl-exit ()
  66   (let (bbdb-buf)
  67     (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
  68         (kill-buffer bbdb-buf)))
  69   (bbdb-offer-save))
  70
  71 (defun bbdb-wl-get-update-record ()
  72   (if (or (null bbdb-wl-folder-regexp)
  73           (string-match
  74            bbdb-wl-folder-regexp
  75            (with-current-buffer
  76                wl-message-buffer-cur-summary-buffer
  77              (wl-summary-buffer-folder-name))))
  78       (with-current-buffer (wl-message-get-original-buffer)
  79         (bbdb-wl-update-record)
  80         (run-hooks 'bbdb-wl-get-update-record-hook))))
  81
  82 (defun bbdb-wl-hide-bbdb-buffer ()
  83   (let (bbdb-buf bbdb-win)
  84     (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
  85         (if (setq bbdb-win (get-buffer-window bbdb-buf))
  86             (delete-window bbdb-win)))))
  87
  88 (defun bbdb-wl-show-bbdb-buffer ()
  89   (save-selected-window
  90     (if (get-buffer-window bbdb-buffer-name)
  91         nil
  92       (let ((mes-win (get-buffer-window
  93                       (save-excursion
  94                         (if (buffer-live-p  wl-current-summary-buffer)
  95                             (set-buffer wl-current-summary-buffer))
  96                         wl-message-buffer)))
  97             (cur-win (selected-window))
  98             (b (current-buffer)))
  99         (and mes-win (select-window mes-win))
 100         (let ((size (min
 101                      (- (window-height mes-win)
 102                         window-min-height 1)
 103                      (- (window-height mes-win)
 104                         (max window-min-height
 105                              (1+ bbdb-pop-up-target-lines))))))
 106           (split-window mes-win (if (> size 0) size window-min-height)))
 107         ;; goto the bottom of the two...
 108         (select-window (next-window))
 109         ;; make it display *BBDB*...
 110         (let ((pop-up-windows nil))
 111           (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
 112
 113 (defun bbdb-wl-get-petname (from)
 114   "For `wl-summary-get-petname-function'."
 115   (let* ((address (wl-address-header-extract-address from))
 116          (record (bbdb-search-simple nil address)))
 117     (and record
 118          (or (bbdb-record-name record)
 119              (car (bbdb-record-name record))))))
 120
 121 (defun bbdb-wl-from-func (string)
 122   "A candidate From field STRING.  For `wl-summary-from-function'."
 123   (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
 124                                       string)))
 125         first-name last-name from-str)
 126     (if hit
 127         (progn
 128           (setq first-name (aref hit 0))
 129           (setq last-name (aref hit 1))
 130           (cond ((and (null first-name)
 131                       (null last-name))
 132                  (setq from-str string))
 133                 ((and first-name last-name)
 134                  (setq from-str (concat first-name " " last-name)))
 135                 ((or first-name last-name)
 136                  (setq from-str (or first-name last-name))))
 137           from-str)
 138       string)))
 139
 140 (if (not (boundp 'bbdb-get-addresses-from-headers))
 141     (defvar bbdb-get-addresses-from-headers
 142       '("From" "Resent-From" "Reply-To")))
 143
 144 (if (not (boundp 'bbdb-get-addresses-to-headers))
 145     (defvar bbdb-get-addresses-to-headers
 146       '("Resent-To" "Resent-CC" "To" "CC" "BCC")))
 147
 148 (if (not (boundp 'bbdb-get-addresses-headers))
 149     (defvar bbdb-get-addresses-headers
 150       (append bbdb-get-addresses-from-headers bbdb-get-addresses-to-headers)))
 151
 152 (defun bbdb-wl-get-addresses (&optional only-first-address)
 153   "Return real name and email address of sender respectively recipients.
 154 If an address matches `bbdb-user-mail-names' it will be ignored.
 155 The headers to search can be configured by `bbdb-get-addresses-headers'."
 156   (save-excursion
 157     (save-restriction
 158       (std11-narrow-to-header)
 159       (let ((headers bbdb-get-addresses-headers)
 160             (uninteresting-senders bbdb-user-mail-names)
 161             addrlist header structures structure fn ad)
 162         (while headers
 163           (setq header (std11-fetch-field (car headers)))
 164           (when header
 165             (setq structures (std11-parse-addresses-string
 166                               (std11-unfold-string header)))
 167             (while (and (setq structure (car structures))
 168                         (eq (car structure) 'mailbox))
 169               (setq fn (std11-full-name-string structure)
 170                     fn (and fn
 171                             (with-temp-buffer ; to keep raw buffer unibyte.
 172                               (elmo-set-buffer-multibyte
 173                                default-enable-multibyte-characters)
 174                               (eword-decode-string
 175                                (decode-mime-charset-string
 176                                 fn wl-mime-charset))))
 177                     ad (std11-address-string structure))
 178
 179               ;; ignore uninteresting addresses, this is kinda gross!
 180               (when (or (not (stringp uninteresting-senders))
 181                         (not (or
 182                               (and fn (string-match uninteresting-senders fn))
 183                               (and ad (string-match uninteresting-senders ad)))))
 184                 (add-to-list 'addrlist (list fn ad)))
 185
 186               (if (and only-first-address addrlist)
 187                   (setq structures nil headers nil)
 188                 (setq structures (cdr structures)))))
 189           (setq headers (cdr headers)))
 190         (nreverse addrlist)))))
 191
 192 (defun bbdb-wl-update-record (&optional offer-to-create)
 193   "Returns the record corresponding to the current WL message,
 194 creating or modifying it as necessary.  A record will be created if
 195 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 196 the user confirms the creation."
 197   (let* ((bbdb-get-only-first-address-p t)
 198          (records (bbdb-wl-update-records offer-to-create)))
 199     (if (and records (listp records))
 200         (car records)
 201       records)))
 202
 203 (defun bbdb-wl-update-records (&optional offer-to-create)
 204   "Returns the records corresponding to the current WL message,
 205 creating or modifying it as necessary.  A record will be created if
 206 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 207 the user confirms the creation."
 208   (save-excursion
 209     (if bbdb-use-pop-up
 210         (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
 211       (let ((key
 212              (save-excursion
 213                (set-buffer
 214                 (save-excursion
 215                   (if (buffer-live-p wl-current-summary-buffer)
 216                       (set-buffer wl-current-summary-buffer))
 217                   wl-message-buffer))
 218                (intern (format
 219                         "%s-%d"
 220                         wl-current-summary-buffer
 221                         wl-message-buffer-cur-number))))
 222             record)
 223         (or (progn (setq record (bbdb-message-cache-lookup key))
 224                    (if (listp record) (nth 1 record) record))
 225             (static-if (not (fboundp 'bbdb-update-records))
 226                 (let* ((from (or (std11-field-body "From") ""))
 227                        (addr (and from
 228                                   (nth 1 (std11-extract-address-components
 229                                           from)))))
 230                   (if (or (null from)
 231                           (null addr)
 232                           (string-match (bbdb-user-mail-names) addr))
 233                       (setq from (or (std11-field-body "To") from)))
 234                   (with-temp-buffer ; to keep raw buffer unibyte.
 235                     (elmo-set-buffer-multibyte
 236                      default-enable-multibyte-characters)
 237                     (setq from (eword-decode-string
 238                                 (decode-mime-charset-string
 239                                  from
 240                                  wl-mime-charset))))
 241                   (if from
 242                       (bbdb-encache-message
 243                        key
 244                        (bbdb-annotate-message-sender
 245                         from t
 246                         (or (bbdb-invoke-hook-for-value
 247                              bbdb/mail-auto-create-p)
 248                             offer-to-create)
 249                         offer-to-create))))
 250               (bbdb-encache-message
 251                key
 252                (bbdb-update-records (bbdb-wl-get-addresses
 253                                      bbdb-get-only-first-address-p)
 254                                     (or (bbdb-invoke-hook-for-value
 255                                          bbdb/mail-auto-create-p)
 256                                         offer-to-create)
 257                                     offer-to-create))))))))
 258
 259 (defun bbdb-wl-annotate-sender (string)
 260   "Add a line to the end of the Notes field of the BBDB record
 261 corresponding to the sender of this message."
 262   (interactive (list (if bbdb-readonly-p
 263                          (error "The Insidious Big Brother Database is read-only")
 264                        (read-string "Comments: "))))
 265   (set-buffer (wl-message-get-original-buffer))
 266   (bbdb-annotate-notes (bbdb-wl-update-record t) string))
 267
 268 (defun bbdb-wl-edit-notes (&optional arg)
 269   "Edit the notes field or (with a prefix arg) a user-defined field
 270 of the BBDB record corresponding to the sender of this message."
 271   (interactive "P")
 272   (wl-summary-set-message-buffer-or-redisplay)
 273   (set-buffer (wl-message-get-original-buffer))
 274   (let ((record (or (bbdb-wl-update-record t) (error ""))))
 275     (bbdb-display-records (list record))
 276     (if arg
 277         (bbdb-record-edit-property record nil t)
 278       (bbdb-record-edit-notes record t))))
 279
 280 (defun bbdb-wl-show-records (&optional headers)
 281   "Display the contents of the BBDB for the sender of this message.
 282 This buffer will be in `bbdb-mode', with associated keybindings."
 283   (interactive)
 284   (wl-summary-set-message-buffer-or-redisplay)
 285   (set-buffer (wl-message-get-original-buffer))
 286   (let ((bbdb-get-addresses-headers (or headers bbdb-get-addresses-headers))
 287         (bbdb-update-records-mode 'annotating)
 288         (bbdb-message-cache nil)
 289         (bbdb-user-mail-names nil)
 290         records bbdb-win)
 291     (setq records (bbdb-wl-update-records t))
 292     (if records
 293         (progn
 294           (bbdb-wl-pop-up-bbdb-buffer)
 295           (bbdb-display-records (if (listp records) records
 296                                   (list records))))
 297       (bbdb-undisplay-records))
 298     (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
 299     (and bbdb-win
 300          (select-window bbdb-win))
 301     records))
 302
 303 (defun bbdb-wl-show-all-recipients ()
 304   "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
 305   (interactive)
 306   (bbdb-wl-show-records  bbdb-get-addresses-to-headers))
 307
 308 (defun bbdb-wl-show-sender (&optional show-recipients)
 309   "Display the contents of the BBDB for the senders of this message.
 310 With a prefix argument show the recipients instead,
 311 with two prefix arguments show all records.
 312 This buffer will be in `bbdb-mode', with associated keybindings."
 313   (interactive "p")
 314   (cond ((= 4 show-recipients)
 315          (bbdb-wl-show-all-recipients))
 316         ((= 16 show-recipients)
 317          (bbdb-wl-show-records))
 318         (t
 319          (if (null (bbdb-wl-show-records bbdb-get-addresses-from-headers))
 320              (bbdb-wl-show-all-recipients)))))
 321
 322 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
 323   "Make the *BBDB* buffer be displayed along with the WL window(s),
 324 displaying the record corresponding to the sender of the current message."
 325   (if (get-buffer-window bbdb-buffer-name)
 326       nil
 327     (let ((mes-win (get-buffer-window
 328                     (save-excursion
 329                       (if (buffer-live-p  wl-current-summary-buffer)
 330                           (set-buffer wl-current-summary-buffer))
 331                       wl-message-buffer)))
 332           (cur-win (selected-window))
 333           (b (current-buffer)))
 334       (and mes-win
 335            (select-window mes-win))
 336       (let ((size (min
 337                    (- (window-height mes-win)
 338                       window-min-height 1)
 339                    (- (window-height mes-win)
 340                       (max window-min-height
 341                            (1+ bbdb-pop-up-target-lines))))))
 342         (split-window mes-win (if (> size 0) size window-min-height)))
 343       ;; goto the bottom of the two...
 344       (select-window (next-window))
 345       ;; make it display *BBDB*...
 346       (let ((pop-up-windows nil))
 347         (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
 348       ;; select the original window we were in...
 349       (select-window cur-win)
 350       ;; and make sure the current buffer is correct as well.
 351       (set-buffer b)))
 352   (let ((bbdb-gag-messages t)
 353         (bbdb-use-pop-up nil)
 354         (bbdb-electric-p nil))
 355     (let* ((records (static-if (fboundp 'bbdb-update-records)
 356                         (bbdb-wl-update-records offer-to-create)
 357                       (bbdb-wl-update-record offer-to-create)))
 358            ;; BBDB versions v2.33 and later.
 359            (bbdb-display-layout
 360             (cond ((boundp 'bbdb-pop-up-display-layout)
 361                    (symbol-value 'bbdb-pop-up-display-layout))
 362                   ((boundp 'bbdb-pop-up-elided-display)
 363                    (symbol-value 'bbdb-pop-up-elided-display))))
 364            ;; BBDB versions prior to v2.33,
 365            (bbdb-elided-display bbdb-display-layout)
 366            (b (current-buffer)))
 367       (bbdb-display-records (if (listp records) records
 368                               (list records)))
 369       (set-buffer b)
 370       records)))
 371
 372 (defun bbdb-wl-send-mail-internal (&optional to subj records)
 373   (unwind-protect
 374       (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
 375     (condition-case nil (delete-other-windows) (error))))
 376
 377 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
 378 ;;;
 379 (eval-and-compile
 380   (if (fboundp 'bbdb-wl-extract-field-value-internal)
 381 ;;(if (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
 382       nil
 383     (if (and (string< bbdb-version "1.58")
 384              ;;(not (fboundp 'bbdb-extract-field-value) ;; defined as autoload
 385              (not (fboundp 'bbdb-header-start)))
 386         (load "bbdb-hooks")
 387       (require 'bbdb-hooks))
 388     (fset 'bbdb-wl-extract-field-value-internal
 389           (cond
 390            ((fboundp 'tm:bbdb-extract-field-value)
 391             (symbol-function 'tm:bbdb-extract-field-value))
 392            (t (symbol-function 'bbdb-extract-field-value))))
 393     (defun bbdb-extract-field-value (field)
 394       (let ((value (bbdb-wl-extract-field-value-internal field)))
 395         (with-temp-buffer ; to keep raw buffer unibyte.
 396           (elmo-set-buffer-multibyte
 397            default-enable-multibyte-characters)
 398           (and value
 399                (eword-decode-string value)))))
 400     ))
 401
 402
 403 (provide 'bbdb-wl)
 404
 405 ;;; bbdb-wl.el ends here