utils/bbdb-wl.el

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