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