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   (defvar bbdb-pop-up-elided-display nil))
  28 ;;  (or (fboundp 'bbdb-wl-extract-field-value-internal)
  29 ;;      (defun bbdb-wl-extract-field-value-internal (field))))
  30 (require 'bbdb)
  31
  32 (defvar bbdb-wl-get-update-record-hook nil)
  33
  34 (defun bbdb-wl-setup ()
  35   (add-hook 'wl-message-redisplay-hook 'bbdb-wl-get-update-record)
  36   (add-hook 'wl-summary-exit-hook 'bbdb-wl-hide-bbdb-buffer)
  37   (add-hook 'wl-message-window-deleted-hook 'bbdb-wl-hide-bbdb-buffer)
  38   (add-hook 'wl-exit-hook 'bbdb-wl-exit)
  39   (add-hook 'wl-summary-toggle-disp-off-hook 'bbdb-wl-hide-bbdb-buffer)
  40   (add-hook 'wl-summary-toggle-disp-folder-on-hook 'bbdb-wl-hide-bbdb-buffer)
  41   (add-hook 'wl-summary-toggle-disp-folder-off-hook 'bbdb-wl-hide-bbdb-buffer)
  42   (add-hook 'wl-summary-toggle-disp-folder-message-resumed-hook
  43             'bbdb-wl-show-bbdb-buffer)
  44   (add-hook 'wl-summary-mode-hook
  45             (function
  46              (lambda ()
  47                (define-key (current-local-map) ":" 'bbdb-wl-show-sender)
  48                (define-key (current-local-map) ";" 'bbdb-wl-edit-notes))))
  49   (add-hook 'wl-summary-exit-hook 'bbdb-flush-all-caches)
  50   (add-hook 'wl-summary-exec-hook 'bbdb-flush-all-caches)
  51   (add-hook 'wl-mail-setup-hook
  52             (function
  53              (lambda ()
  54 ;;;            (local-set-key "\M-\t" 'bbdb-complete-name)
  55                (define-key (current-local-map) "\M-\t" 'bbdb-complete-name)
  56                ))))
  57
  58 (defun bbdb-wl-exit ()
  59   (let (bbdb-buf)
  60     (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
  61         (kill-buffer bbdb-buf)))
  62   (bbdb-save-db t))
  63
  64 (defun bbdb-wl-get-update-record ()
  65   (set-buffer (wl-message-get-original-buffer))
  66   (bbdb-wl-update-record)
  67   (run-hooks 'bbdb-wl-get-update-record-hook))
  68
  69 (defun bbdb-wl-hide-bbdb-buffer ()
  70   (let (bbdb-buf bbdb-win)
  71     (if (setq bbdb-buf (get-buffer bbdb-buffer-name))
  72         (if (setq bbdb-win (get-buffer-window bbdb-buf))
  73             (delete-window bbdb-win)))))
  74
  75 (defun bbdb-wl-show-bbdb-buffer ()
  76   (save-selected-window
  77     (if (get-buffer-window bbdb-buffer-name)
  78         nil
  79       (let ((mes-win (get-buffer-window
  80                       (save-excursion
  81                         (if (buffer-live-p  wl-current-summary-buffer)
  82                             (set-buffer wl-current-summary-buffer))
  83                         wl-message-buf-name)))
  84             (cur-win (selected-window))
  85             (b (current-buffer)))
  86         (and mes-win (select-window mes-win))
  87         (let ((size (min
  88                      (- (window-height mes-win)
  89                         window-min-height 1)
  90                      (- (window-height mes-win)
  91                         (max window-min-height
  92                              (1+ bbdb-pop-up-target-lines))))))
  93           (split-window mes-win (if (> size 0) size window-min-height)))
  94         ;; goto the bottom of the two...
  95         (select-window (next-window))
  96         ;; make it display *BBDB*...
  97         (let ((pop-up-windows nil))
  98           (switch-to-buffer (get-buffer-create bbdb-buffer-name)))))))
  99
 100 (defun bbdb-wl-get-petname (from)
 101   "For `wl-summary-get-petname-func'."
 102   (let* ((address (wl-address-header-extract-address from))
 103          (record (bbdb-search-simple nil address)))
 104     (and record
 105          (or (bbdb-record-name record)
 106              (car (bbdb-record-name record))))))
 107
 108 (defun bbdb-wl-from-func (string)
 109   "A candidate From field STRING.  For `wl-summary-from-func'."
 110   (let ((hit (bbdb-search-simple nil (wl-address-header-extract-address
 111                                       string)))
 112         first-name last-name from-str)
 113     (if hit
 114         (progn
 115           (setq first-name (aref hit 0))
 116           (setq last-name (aref hit 1))
 117           (cond ((and (null first-name)
 118                       (null last-name))
 119                  (setq from-str string))
 120                 ((and first-name last-name)
 121                  (setq from-str (concat first-name " " last-name)))
 122                 ((or first-name last-name)
 123                  (setq from-str (or first-name last-name))))
 124           from-str)
 125       string)))
 126
 127 (defun bbdb-wl-update-record (&optional offer-to-create)
 128   "Returns the record corresponding to the current WL message,
 129 creating or modifying it as necessary.  A record will be created if
 130 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
 131 the user confirms the creation."
 132   (save-excursion
 133     (if bbdb-use-pop-up
 134         (bbdb-wl-pop-up-bbdb-buffer offer-to-create)
 135       (let ((key
 136              (save-excursion
 137                (set-buffer
 138                 (save-excursion
 139                   (if (buffer-live-p wl-current-summary-buffer)
 140                       (set-buffer wl-current-summary-buffer))
 141                   wl-message-buf-name))
 142                (intern (format
 143                         "%s-%d"
 144                         wl-current-summary-buffer
 145                         wl-message-buffer-cur-number)))))
 146         (or (bbdb-message-cache-lookup key nil)
 147             (and key
 148                  (let* ((from (or (std11-field-body "From") ""))
 149                         (addr (and from
 150                                    (nth 1 (std11-extract-address-components
 151                                            from)))))
 152                    (if (or (null from)
 153                            (null addr)
 154                            (string-match (bbdb-user-mail-names) addr))
 155                        (setq from (or (std11-field-body "To") from)))
 156                    (with-temp-buffer ; to keep raw buffer unibyte.
 157                      (elmo-set-buffer-multibyte
 158                       default-enable-multibyte-characters)
 159                      (setq from (eword-decode-string
 160                                  (decode-mime-charset-string
 161                                   from
 162                                   wl-mime-charset))))
 163                    (if from
 164                        (bbdb-encache-message
 165                         key
 166                         (bbdb-annotate-message-sender
 167                          from t
 168                          (or (bbdb-invoke-hook-for-value
 169                               bbdb/mail-auto-create-p)
 170                              offer-to-create)
 171                          offer-to-create))))))))))
 172
 173 (defun bbdb-wl-annotate-sender (string)
 174   "Add a line to the end of the Notes field of the BBDB record
 175 corresponding to the sender of this message."
 176   (interactive (list (if bbdb-readonly-p
 177                          (error "The Insidious Big Brother Database is read-only")
 178                        (read-string "Comments: "))))
 179   (set-buffer (wl-message-get-original-buffer))
 180   (bbdb-annotate-notes (bbdb-wl-update-record t) string))
 181
 182 (defun bbdb-wl-edit-notes (&optional arg)
 183   "Edit the notes field or (with a prefix arg) a user-defined field
 184 of the BBDB record corresponding to the sender of this message."
 185   (interactive "P")
 186   (wl-summary-redisplay)
 187   (set-buffer (wl-message-get-original-buffer))
 188   (let ((record (or (bbdb-wl-update-record t) (error ""))))
 189     (bbdb-display-records (list record))
 190     (if arg
 191         (bbdb-record-edit-property record nil t)
 192       (bbdb-record-edit-notes record t))))
 193
 194 (defun bbdb-wl-show-sender ()
 195   "Display the contents of the BBDB for the sender of this message.
 196 This buffer will be in `bbdb-mode', with associated keybindings."
 197   (interactive)
 198   (wl-summary-redisplay)
 199   (set-buffer (wl-message-get-original-buffer))
 200   (let ((record (bbdb-wl-update-record t))
 201         bbdb-win)
 202     (if record
 203         (progn
 204           (bbdb-wl-pop-up-bbdb-buffer)
 205           (bbdb-display-records (list record)))
 206       (error "Unperson"))
 207     (setq bbdb-win (get-buffer-window (get-buffer bbdb-buffer-name)))
 208     (and bbdb-win
 209          (select-window bbdb-win))))
 210
 211
 212 (defun bbdb-wl-pop-up-bbdb-buffer (&optional offer-to-create)
 213   "Make the *BBDB* buffer be displayed along with the WL window(s),
 214 displaying the record corresponding to the sender of the current message."
 215   (if (get-buffer-window bbdb-buffer-name)
 216       nil
 217     (let ((mes-win (get-buffer-window
 218                     (save-excursion
 219                       (if (buffer-live-p  wl-current-summary-buffer)
 220                           (set-buffer wl-current-summary-buffer))
 221                       wl-message-buf-name)))
 222           (cur-win (selected-window))
 223           (b (current-buffer)))
 224       (and mes-win
 225            (select-window mes-win))
 226       (let ((size (min
 227                    (- (window-height mes-win)
 228                       window-min-height 1)
 229                    (- (window-height mes-win)
 230                       (max window-min-height
 231                            (1+ bbdb-pop-up-target-lines))))))
 232         (split-window mes-win (if (> size 0) size window-min-height)))
 233       ;; goto the bottom of the two...
 234       (select-window (next-window))
 235       ;; make it display *BBDB*...
 236       (let ((pop-up-windows nil))
 237         (switch-to-buffer (get-buffer-create bbdb-buffer-name)))
 238       ;; select the original window we were in...
 239       (select-window cur-win)
 240       ;; and make sure the current buffer is correct as well.
 241       (set-buffer b)))
 242   (let ((bbdb-gag-messages t)
 243         (bbdb-use-pop-up nil)
 244         (bbdb-electric-p nil))
 245     (let ((record (bbdb-wl-update-record offer-to-create))
 246           (bbdb-elided-display (bbdb-pop-up-elided-display))
 247           (b (current-buffer)))
 248       (bbdb-display-records (if record (list record) nil))
 249       (set-buffer b)
 250       record)))
 251
 252 (defun bbdb-wl-send-mail-internal (&optional to subj records)
 253   (unwind-protect
 254       (wl-draft (wl-address-header-extract-address to) "" (or subj ""))
 255     (condition-case nil (delete-other-windows) (error))))
 256
 257 ;;; @ bbdb-extract-field-value -- stolen from tm-bbdb.
 258 ;;;
 259 (and (not (fboundp 'bbdb-wl-extract-field-value-internal))
 260 ;;;  (not (fboundp 'PLEASE_REPLACE_WITH_SEMI-BASED_MIME-BBDB)) ;; mime-bbdb
 261     (progn
 262       (if (and (string< bbdb-version "1.58")
 263                ;; (not (fboundp 'bbdb-extract-field-value) ; defined as autoload
 264                (not (fboundp 'bbdb-header-start)))
 265           (load "bbdb-hooks")
 266         (require 'bbdb-hooks))
 267       (fset 'bbdb-wl-extract-field-value-internal
 268             (cond
 269              ((fboundp 'tm:bbdb-extract-field-value)
 270               (symbol-function 'tm:bbdb-extract-field-value))
 271              (t (symbol-function 'bbdb-extract-field-value))))
 272       (defun bbdb-extract-field-value (field)
 273         (let ((value (bbdb-wl-extract-field-value-internal field)))
 274           (with-temp-buffer ; to keep raw buffer unibyte.
 275             (elmo-set-buffer-multibyte
 276              default-enable-multibyte-characters)
 277             (and value
 278                  (eword-decode-string value)))))
 279       ))
 280
 281
 282 (provide 'bbdb-wl)
 283
 284 ;;; bbdb-wl.el ends here