cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-mhe.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is part of the Insidious Big Brother Database (aka BBDB),
   4 ;;; copyright (c) 1991 Todd Kaufmann <toad@cs.cmu.edu>
   5 ;;; Interface to mh-e version 3.7 or later (modeled after bbdb-rmail).
   6 ;;; Created  5-Mar-91;
   7 ;;; Modified: 28-Jul-94 by Fritz Knabe <knabe@ecrc.de>
   8 ;;;                        Jack Repenning <jackr@dblues.wpd.sgi.com>
   9
  10 ;;; The Insidious Big Brother Database is free software; you can redistribute
  11 ;;; it and/or modify it under the terms of the GNU General Public License as
  12 ;;; published by the Free Software Foundation; either version 1, or (at your
  13 ;;; option) any later version.
  14 ;;;
  15 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  16 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  17 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  18 ;;; details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;
  25 ;; $Id: bbdb-mhe.el,v 1.6 2007-02-23 20:24:07 fenk Exp $
  26 ;;
  27
  28 (eval-and-compile
  29   (require 'bbdb)
  30   (require 'bbdb-com)
  31   (require 'mail-utils)
  32   ;; We advise several mh-e functions
  33   (require 'mh-e)
  34   (if (fboundp 'mh-version)
  35       (require 'mh-comp))              ; For mh-e 4.x
  36   (require 'advice))
  37
  38 (defmacro bbdb/mh-cache-key (message)
  39   "Return a (numeric) key for MESSAGE"
  40   (`(let* ((attrs (file-attributes (, message)))
  41            (status-time (nth 6 attrs))
  42            (status-time-2 (cdr status-time))
  43            (inode (nth 10 attrs)))
  44       (logxor (if (integerp inode) ;; if inode is larger than an emacs int,
  45                   inode               ;; it's returned as a dotted pair
  46                 (car inode))
  47               (car status-time)
  48               ;; We need the following test because XEmacs returns the
  49               ;; status time as a dotted pair, whereas FSF and Epoch
  50               ;; return it as list.
  51               (if (integerp status-time-2)
  52                   status-time-2
  53                 (car status-time-2))))))
  54
  55 ;;;###autoload
  56 (defun bbdb/mh-update-record (&optional offer-to-create)
  57   "Returns the record corresponding to the current MH message, creating or
  58 modifying it as necessary.  A record will be created if
  59 bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
  60 the user confirms the creation."
  61   (save-excursion
  62     (and mh-show-buffer (set-buffer mh-show-buffer))
  63     (if bbdb-use-pop-up
  64         (bbdb/mh-pop-up-bbdb-buffer offer-to-create)
  65       (let ((msg (bbdb/mh-cache-key buffer-file-name))
  66             records record)
  67         (if (eq msg 0) (setq msg nil))  ; 0 could mean trouble; be safe.
  68         (setq records (bbdb-message-cache-lookup msg))
  69         (if records
  70             (car records)
  71           (let ((from (bbdb/mh-get-field "^From[ \t]*:")))
  72             (if (or (string= "" from)
  73                     (string-match (bbdb-user-mail-names)
  74                                   (mail-strip-quoted-names from)))
  75                 ;; if logged-in user sent this, use recipients.
  76                 (progn
  77                   (setq from (bbdb/mh-get-field "^To[ \t]*:"))
  78                   (if (or (string= "" from)
  79                           (string-match (bbdb-user-mail-names)
  80                                         (mail-strip-quoted-names from)))
  81                       (setq from nil))))
  82             (if from
  83                 (setq record
  84                       (bbdb-annotate-message-sender
  85                        from t
  86                        (or (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)
  87                            offer-to-create)
  88                        ;; ugh. what the hell?
  89                        (or offer-to-create
  90                            (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)))))
  91             (if (and msg record) (bbdb-encache-message msg (list record)))
  92             ;; return one record
  93             record))))))
  94
  95 ;;;###autoload
  96 (defun bbdb/mh-annotate-sender (string &optional replace)
  97   "Add a line to the end of the Notes field of the BBDB record
  98 corresponding to the sender of this message.  If REPLACE is non-nil,
  99 replace the existing notes entry (if any)."
 100   (interactive (list (if bbdb-readonly-p
 101                          (error "The Insidious Big Brother Database is read-only.")
 102                          (read-string "Comments: "))))
 103   (mh-show)
 104   (let ((b (current-buffer))
 105         (p (point)))
 106     (set-buffer mh-show-buffer)
 107     (bbdb-annotate-notes (bbdb/mh-update-record t) string 'notes replace)
 108     (set-buffer b)
 109     (goto-char p)))
 110
 111
 112 (defun bbdb/mh-edit-notes (&optional arg)
 113   "Edit the notes field or (with a prefix arg) a user-defined field
 114 of the BBDB record corresponding to the sender of this message."
 115   (interactive "P")
 116   (mh-show)
 117   (let ((b (current-buffer))
 118         (p (point)))
 119     (set-buffer mh-show-buffer)
 120     (let (bbdb-electric-p (record (or (bbdb/mh-update-record t) (error ""))))
 121       (bbdb-display-records (list record))
 122       (if arg
 123           (bbdb-record-edit-property record nil t)
 124         (bbdb-record-edit-notes record t)))
 125     (set-buffer b)
 126     (goto-char p)))
 127
 128
 129 ;;;###autoload
 130 (defun bbdb/mh-show-sender ()
 131   "Display the contents of the BBDB for the sender of this message.
 132 This buffer will be in bbdb-mode, with associated keybindings."
 133   (interactive)
 134   (mh-show)
 135   (let ((b (current-buffer))
 136         (p (point)))
 137     (set-buffer mh-show-buffer)
 138     (let ((record (bbdb/mh-update-record t)))
 139       (if record
 140           (bbdb-display-records (list record))
 141         (error "unperson")))
 142     (set-buffer b)
 143     (goto-char p)))
 144
 145
 146 (defun bbdb/mh-pop-up-bbdb-buffer (&optional offer-to-create)
 147   "Make the *BBDB* buffer be displayed along with the MH window,
 148 displaying the record corresponding to the sender of the current message."
 149   (bbdb-pop-up-bbdb-buffer
 150     (function (lambda (w)
 151       (let ((b (current-buffer)))
 152         (set-buffer (window-buffer w))
 153         (prog1 (eq major-mode 'mh-folder-mode)
 154           (set-buffer b))))))
 155   (let ((bbdb-gag-messages t)
 156         (bbdb-use-pop-up nil)
 157         (bbdb-electric-p nil))
 158     (let ((record (bbdb/mh-update-record offer-to-create)))
 159       (bbdb-display-records (if record (list record) nil)
 160                             bbdb-pop-up-display-layout)
 161       record)))
 162
 163
 164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 165 ;; this is a more strict version of mh-get-field which takes an regexp
 166
 167 (defun bbdb/mh-get-field (field)
 168   ;; Find and return the value of field FIELD (regexp) in the current buffer.
 169   ;; Returns the empty string if the field is not in the message.
 170   (let ((case-fold-search nil))
 171     (goto-char (point-min))
 172     (cond ((not (re-search-forward field nil t)) "")
 173           ((looking-at "[\t ]*$") "")
 174           (t (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
 175            (let ((field (buffer-substring (match-beginning 1) (match-end 1)))
 176                  (end-of-match (point)))
 177              (forward-line)
 178              (while (looking-at "[ \t]") (forward-line 1))
 179              (backward-char 1)
 180              (if (<= (point) end-of-match)
 181                  field
 182                  (format "%s%s" field
 183                          (buffer-substring end-of-match (point)))))))))
 184
 185 (defadvice mh-process-commands (after mh-bbdb-process act)
 186   (bbdb-offer-save))
 187
 188 (defadvice mh-send (before mh-bbdb-send act)
 189   (interactive (list
 190                 (bbdb-read-addresses-with-completion "To: ")
 191                 (bbdb-read-addresses-with-completion "Cc: ")
 192                 (read-string "Subject: "))))
 193
 194 (defadvice mh-send-other-window (before mh-bbdb-send-other act)
 195   (interactive (list
 196                 (bbdb-read-addresses-with-completion "To: ")
 197                 (bbdb-read-addresses-with-completion "Cc: ")
 198                 (read-string "Subject: "))))
 199
 200 (defadvice mh-forward (before mh-bbdb-forward act)
 201   (interactive (list (bbdb-read-addresses-with-completion "To: ")
 202                      (bbdb-read-addresses-with-completion "Cc: ")
 203                      (if current-prefix-arg
 204                          (mh-read-seq-default "Forward" t)
 205                        (mh-get-msg-num t)))))
 206
 207 (defadvice mh-redistribute (before mh-bbdb-redist act)
 208   (interactive (list
 209                 (bbdb-read-addresses-with-completion "Redist-To: ")
 210                 (bbdb-read-addresses-with-completion "Redist-Cc: ")
 211                 (mh-get-msg-num t))))
 212
 213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 214 ;; mail from bbdb-mode using mh
 215
 216 ;; these redefine the bbdb-send-mail functions to use mh-send.
 217
 218 ;;; Install bbdb into mh-e's show-message function
 219
 220 ;;;###autoload
 221 (defun bbdb-insinuate-mh ()
 222   "Call this function to hook BBDB into MH-E."
 223   (define-key mh-folder-mode-map ":" 'bbdb/mh-show-sender)
 224   (define-key mh-folder-mode-map ";" 'bbdb/mh-edit-notes)
 225   (define-key mh-letter-mode-map "\M-;" 'bbdb-complete-name)
 226   (add-hook 'mh-show-hook 'bbdb/mh-update-record)
 227   (define-key mh-letter-mode-map "\e\t" 'bbdb-complete-name))
 228
 229 (provide 'bbdb-mhe)