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