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