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

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
   4 ;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
   5 ;;; Interface to VM (View Mail) 5.31 or greater.  See bbdb.texinfo.
   6
   7 ;;; The Insidious Big Brother Database is free software; you can redistribute
   8 ;;; it and/or modify it under the terms of the GNU General Public License as
   9 ;;; published by the Free Software Foundation; either version 1, or (at your
  10 ;;; option) any later version.
  11 ;;;
  12 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  13 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15 ;;; details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 ;;
  22 ;; $Id: bbdb-vm.el,v 1.8 2007-02-23 20:24:08 fenk Exp $
  23 ;;
  24
  25 (eval-and-compile
  26   (require 'cl)
  27   (require 'bbdb)
  28   (require 'bbdb-com)
  29   (require 'bbdb-snarf)
  30   (require 'vm-autoload)
  31   (require 'vm)
  32
  33   (if (not (fboundp 'vm-record-and-change-message-pointer))
  34       (load-library "vm-motion"))
  35   (if (not (fboundp 'vm-su-from))
  36       (load-library "vm-summary"))
  37   (or (boundp 'vm-mode-map)
  38       (load-library "vm-vars")))
  39
  40 (defun bbdb/vm-get-header-content (header-field msg)
  41   (let ((content (vm-get-header-contents msg (concat header-field ":"))))
  42     (if content
  43         (vm-decode-mime-encoded-words-in-string content))))
  44
  45 (defcustom bbdb/vm-update-records-mode
  46   '(if (vm-new-flag msg) 'annotating 'searching)
  47   "Controls how `bbdb/vm-update-records' processes email addresses.
  48 Set this to an expression which evaluates either to 'searching or
  49 'annotating.  When set to 'annotating email addresses will be fed to
  50 `bbdb-annotate-message-sender' in order to update existing records or create
  51 new ones.  A value of 'searching will search just for existing records having
  52 the right net.
  53
  54 The default is to annotate only new messages."
  55   :group 'bbdb-mua-specific-vm
  56   :type '(choice (const :tag "annotating all messages"
  57                         annotating)
  58                  (const :tag "annotating no messages"
  59                         searching)
  60                  (const :tag "annotating only new messages"
  61                         (if (vm-new-flag msg) 'annotating 'searching))
  62                  (sexp  :tag "user defined")))
  63
  64 ;;;###autoload
  65 (defun bbdb/vm-update-record (&optional offer-to-create)
  66   (let* ((bbdb-get-only-first-address-p t)
  67          (records (bbdb/vm-update-records offer-to-create)))
  68     (if records (car records) nil)))
  69
  70 ;;;###autoload
  71 (defun bbdb/vm-update-records (&optional offer-to-create)
  72   "Returns the records corresponding to the current VM message,
  73 creating or modifying them as necessary.  A record will be created if
  74 bbdb/mail-auto-create-p is non-nil or if OFFER-TO-CREATE is true, and
  75 the user confirms the creation.
  76
  77 The variable `bbdb/vm-update-records-mode' controls what actions
  78 are performed and it might override `bbdb-update-records-mode'.
  79
  80 When hitting C-g once you will not be asked anymore for new people listed
  81 in this message, but it will search only for existing records.  When hitting
  82 C-g again it will stop scanning."
  83   (vm-select-folder-buffer)
  84   (vm-check-for-killed-summary)
  85   (vm-error-if-folder-empty)
  86   (let ((msg (car vm-message-pointer))
  87         (enable-local-variables t)      ; ...or vm bind this to nil.
  88         (inhibit-quit nil)              ; vm better not bind this to t!
  89         (bbdb/vm-offer-to-create offer-to-create)
  90         cache records)
  91
  92     ;; ignore cache if we may be creating a record, since the cache
  93     ;; may otherwise tell us that the user didn't want a record for
  94     ;; this person.
  95     (if (not bbdb/vm-offer-to-create)
  96         (setq cache (and msg (bbdb-message-cache-lookup msg))))
  97
  98     (if cache
  99         (setq records (if bbdb-get-only-first-address-p
 100                           (list (car cache))
 101                         cache))
 102
 103       (let ((bbdb-update-records-mode (or bbdb/vm-update-records-mode
 104                                           bbdb-update-records-mode)))
 105         (setq records (bbdb-update-records
 106                        (bbdb-get-addresses bbdb-get-only-first-address-p
 107                                            vm-summary-uninteresting-senders
 108                                            'bbdb/vm-get-header-content
 109                                            (vm-real-message-of msg))
 110                        bbdb/mail-auto-create-p
 111                        offer-to-create))
 112
 113         (bbdb-encache-message msg records)))
 114     records))
 115
 116 ;;;###autoload
 117 (defun bbdb/vm-annotate-sender (string &optional replace)
 118   "Add a line to the end of the Notes field of the BBDB record
 119 corresponding to the sender of this message.  If REPLACE is non-nil,
 120 replace the existing notes entry (if any)."
 121   (interactive
 122    (list (if bbdb-readonly-p
 123          (error "The Insidious Big Brother Database is read-only.")
 124        (read-string "Comments: "))))
 125   (vm-follow-summary-cursor)
 126   (let ((record (or (bbdb/vm-update-record t) (error "unperson"))))
 127     (bbdb-annotate-notes record string 'notes replace)))
 128
 129 (defun bbdb/vm-edit-notes (&optional arg)
 130   "Edit the notes field or (with a prefix arg) a user-defined field
 131 of the BBDB record corresponding to the sender of this message."
 132   (interactive "P")
 133   (vm-follow-summary-cursor)
 134   (let ((record (or (bbdb/vm-update-record t) (error "unperson"))))
 135     (bbdb-display-records (list record))
 136     (if arg
 137         (bbdb-record-edit-property record nil t)
 138       (bbdb-record-edit-notes record t))))
 139
 140 ;;;###autoload
 141 (defun bbdb/vm-show-records (&optional address-class)
 142   "Display the contents of the BBDB for the sender of this message.
 143 This buffer will be in bbdb-mode, with associated keybindings."
 144   (interactive)
 145   (vm-follow-summary-cursor)
 146   (let ((bbdb-get-addresses-headers
 147          (if address-class
 148              (list (assoc address-class bbdb-get-addresses-headers))
 149            bbdb-get-addresses-headers))
 150         (bbdb/vm-update-records-mode 'annotating)
 151         (bbdb-message-cache nil)
 152         ;; should we move this to bbdb/vm-show-sender?
 153         (bbdb-user-mail-names nil)
 154         (vm-summary-uninteresting-senders nil)
 155         records)
 156     (setq records (bbdb/vm-update-records t))
 157     (if records
 158         (bbdb-display-records records)
 159       (bbdb-undisplay-records))
 160     records))
 161
 162 ;;;###autoload
 163 (defun bbdb/vm-show-all-recipients ()
 164   "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'."
 165   (interactive)
 166   (let ((bbdb-get-only-first-address-p nil))
 167     (bbdb/vm-show-records 'recipients)))
 168
 169 ;;;###autoload
 170 (defun bbdb/vm-show-sender (&optional show-recipients)
 171   "Display the contents of the BBDB for the senders of this message.
 172 With a prefix argument show the recipients instead,
 173 with two prefix arguments show all records.
 174 This buffer will be in `bbdb-mode', with associated keybindings."
 175   (interactive "p")
 176   (cond ((= 4 show-recipients)
 177          (bbdb/vm-show-all-recipients))
 178         ((= 16 show-recipients)
 179          (let ((bbdb-get-only-first-address-p nil))
 180            (bbdb/vm-show-records)))
 181         (t
 182          (if (null (bbdb/vm-show-records 'authors))
 183              (bbdb/vm-show-all-recipients)))))
 184
 185 (defun bbdb/vm-pop-up-bbdb-buffer (&optional offer-to-create)
 186   "Make the *BBDB* buffer be displayed along with the VM window(s).
 187 Displays the records corresponding to the sender respectively
 188 recipients of the current message.
 189 See `bbdb/vm-get-addresses-headers' and 'bbdb-get-only-first-address-p' for
 190 configuration of what is being displayed."
 191   (save-excursion
 192     (let ((bbdb-gag-messages t)
 193           (bbdb-electric-p nil)
 194           (records (bbdb/vm-update-records offer-to-create))
 195           (bbdb-buffer-name bbdb-buffer-name))
 196
 197       (when (and bbdb-use-pop-up records)
 198         (bbdb-pop-up-bbdb-buffer
 199          (function (lambda (w)
 200                      (let ((b (current-buffer)))
 201                        (set-buffer (window-buffer w))
 202                        (prog1 (eq major-mode 'vm-mode)
 203                          (set-buffer b))))))
 204
 205         ;; Always update the records; if there are no records, empty the
 206         ;; BBDB window. This should be generic, not VM-specific.
 207         (bbdb-display-records records bbdb-pop-up-display-layout))
 208
 209       (when (not records)
 210         (bbdb-undisplay-records)
 211         (if (get-buffer-window bbdb-buffer-name)
 212             (delete-window (get-buffer-window bbdb-buffer-name)))))))
 213
 214 \f
 215 ;; By Alastair Burt <burt@dfki.uni-kl.de>
 216 ;; vm 5.40 and newer support a new summary format, %U<letter>, to call
 217 ;; a user-provided function.  Use "%-17.17UB" instead of "%-17.17F" to
 218 ;; have your VM summary buffers display BBDB's idea of the sender's full
 219 ;; name instead of the name (or lack thereof) in the message itself.
 220
 221 (defun vm-summary-function-B (m &optional to-p)
 222   "Given a VM message returns the BBDB name of the sender.
 223 Respects vm-summary-uninteresting-senders."
 224   (if (and vm-summary-uninteresting-senders (not to-p))
 225       (let ((case-fold-search nil))
 226     (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
 227         (concat vm-summary-uninteresting-senders-arrow
 228             (vm-summary-function-B m t))
 229       (or (bbdb/vm-alternate-full-name  (vm-su-from m))
 230           (vm-su-full-name m))))
 231     (or (bbdb/vm-alternate-full-name (if to-p (vm-su-to m) (vm-su-from m)))
 232     (vm-decode-mime-encoded-words-in-string
 233      (if to-p (vm-su-to-names m) (vm-su-full-name m))))))
 234
 235 (defun bbdb/vm-alternate-full-name (address)
 236   (if address
 237       (let ((entry (bbdb-search-simple
 238                     nil
 239                     (if (and address bbdb-canonicalize-net-hook)
 240                         (bbdb-canonicalize-address address)
 241                       address))))
 242         (if entry
 243             (or (bbdb-record-getprop entry 'mail-name)
 244                 (bbdb-record-name entry))))))
 245
 246 \f
 247 ;; From: Mark Thomas <mthomas@jprc.com>
 248 ;; Subject: auto-folder-alist from bbdb
 249
 250 ;;;###autoload
 251 (defcustom bbdb/vm-set-auto-folder-alist-field 'vm-folder
 252   "*The field which `bbdb/vm-set-auto-folder-alist' searches for."
 253   :group 'bbdb-mua-specific-vm
 254   :type 'symbol)
 255
 256 ;;;###autoload
 257 (defcustom bbdb/vm-set-auto-folder-alist-headers '("From:" "To:" "CC:")
 258   "*The headers used by `bbdb/vm-set-auto-folder-alist'.
 259 The order in this list is the order how matching will be performed!"
 260   :group 'bbdb-mua-specific-vm
 261   :type '(repeat (string :tag "header name")))
 262
 263 ;;;###autoload
 264 (defun bbdb/vm-set-auto-folder-alist ()
 265   "Create a `vm-auto-folder-alist' according to the records in the bbdb.
 266 For each record that has a 'vm-folder' attribute, add an
 267 element (email-regexp . folder) to the `vm-auto-folder-alist'.
 268
 269 The element gets added to the 'element-name' sublist of the
 270 `vm-auto-folder-alist'.
 271
 272 The car of the element consists of all the email addresses for the
 273 bbdb record concatenated with OR; the cdr is the value of the
 274 vm-folder attribute.
 275
 276 If the first character of vm-folders value is a quote ' it will be
 277 parsed as lisp expression and is evaluated to return a folder name,
 278 e.g. define you own function `my-folder-name' and set it to
 279         '(my-folder-name)"
 280   (interactive)
 281   (let* (;; we add the email-address/vm-folder-name pair to this
 282          ;; sublist of the vm-auto-folder-alist variable
 283          (headers (reverse bbdb/vm-set-auto-folder-alist-headers))
 284          header
 285          ;; grab the folder list from the vm-auto-folder-alist
 286          folder-list
 287          ;; the raw-notes and vm-folder attributes of the current bbdb
 288          ;; record
 289          notes-field folder
 290          ;; a regexp matching all the email addresses from the bbdb
 291          ;; record
 292          email-regexp
 293          ;;
 294          records)
 295
 296     (setq records
 297           (delete
 298            nil
 299            (mapcar (lambda (r)
 300                      (if (bbdb-record-getprop r bbdb/vm-set-auto-folder-alist-field)
 301                          r))
 302                    (bbdb-records))))
 303
 304     (while headers
 305       (setq header (car headers) headers (cdr headers))
 306       ;; create the folder-list in vm-auto-folder-alist if it doesn't exist
 307       (setq folder-list (assoc header vm-auto-folder-alist))
 308       (unless folder-list
 309         (setq vm-auto-folder-alist (cons (list header)
 310                                          vm-auto-folder-alist)
 311               folder-list (assoc header vm-auto-folder-alist)))
 312       (mapcar
 313        (lambda (r)
 314          (setq notes-field (bbdb-record-raw-notes r))
 315          (when (and (listp notes-field)
 316                     (setq folder (cdr (assq bbdb/vm-set-auto-folder-alist-field
 317                                             notes-field))))
 318           ;; quote all the email addresses for the record and join them
 319           ;; with OR
 320            (setq email-regexp (regexp-opt (bbdb-record-net r)))
 321            (unless (or (zerop (length email-regexp))
 322                        (assoc email-regexp folder-list))
 323              ;; be careful: nconc modifies the list in place
 324              (if (equal (elt folder 0) ?\')
 325                  (setq folder (read (substring folder 1))))
 326              (nconc folder-list (list (cons email-regexp folder))))))
 327        records))))
 328
 329 \f
 330 ;;; bbdb/vm-auto-add-label
 331 ;;; Howard Melman, contributed Jun 16 2000
 332 (defcustom bbdb/vm-auto-add-label-list nil
 333   "*List used by `bbdb/vm-auto-add-label' to automatically label messages.
 334 Each element in the list is either a string or a list of two strings.
 335 If a single string then it is used as both the field value to check for
 336 and the label to apply to the message.  If a list of two strings, the first
 337 is the field value to search for and the second is the label to apply."
 338   :group 'bbdb-mua-specific-vm
 339   :type 'list)
 340
 341 (defcustom bbdb/vm-auto-add-label-field bbdb-define-all-aliases-field
 342   "*Fields used by `bbdb/vm-auto-add-label' to automatically label messages.
 343 Value is either a single symbol or a list of symbols of bbdb fields that
 344 `bbdb/vm-auto-add-label' uses to check for labels to apply to messages.
 345 Defaults to `bbdb-define-all-aliases-field' which is typically `mail-alias'."
 346   :group 'bbdb-mua-specific-vm
 347   :type '(choice symbol list))
 348
 349 (defun bbdb/vm-auto-add-label (record)
 350   "Automatically add labels to messages based on the mail-alias field.
 351 Add this to `bbdb-notice-hook' and if using VM each message that bbdb
 352 notices will be checked.  If the sender has a value in the
 353 bbdb/vm-auto-add-label-field  in their BBDB record that
 354 matches a value in `bbdb/vm-auto-add-label-list' then a VM
 355 label will be added to the message.
 356
 357 This works great when `bbdb-user-mail-names' is set.  As a result
 358 mail that you send to people (and copy yourself on) is labeled as well.
 359
 360 This is how you hook it in.
 361 ;;   (add-hook 'bbdb-notice-hook 'bbdb/vm-auto-add-label)
 362 "
 363   (let (field aliases sep)
 364     (and (eq major-mode 'vm-mode)
 365      (mapcar #'(lambda(x)
 366              (and
 367               (setq field (bbdb-record-getprop record x))
 368               (setq sep (or (get x 'field-separator) ","))
 369               (setq aliases (append aliases (bbdb-split field sep)))))
 370          (cond ((listp bbdb/vm-auto-add-label-field)
 371             bbdb/vm-auto-add-label-field)
 372                ((symbolp bbdb/vm-auto-add-label-field)
 373             (list bbdb/vm-auto-add-label-field))
 374                (t (error "Bad value for bbdb/vm-auto-add-label-field"))
 375                ))
 376      (vm-add-message-labels
 377       (mapconcat #'(lambda (l)
 378              (cond ((stringp l)
 379                 (if (member l aliases)
 380                     l))
 381                    ((and (consp l)
 382                      (stringp (car l))
 383                      (stringp (cdr l)))
 384                 (if (member (car l) aliases)
 385                     (cdr l)))
 386                    (t
 387                 (error "Malformed bbdb/vm-auto-add-label-list")
 388                 )))
 389              bbdb/vm-auto-add-label-list
 390              " ")
 391       1))))
 392
 393 \f
 394 ;;; Automatically add a record for replies.
 395 ;;; Contributed by Robert Fenk, 27 Oct 2000. It only took me 8 months to put
 396 ;;; it in the source...
 397 ;;;
 398 ;;; (add-hook 'vm-reply-hook 'bbdb/vm-force-create) to enable it. You could
 399 ;;; presumably hook it elsewhere as well.
 400 (defun bbdb/vm-force-create ()
 401   "Force automatic adding of a bbdb entry for current message."
 402   (interactive)
 403   (let ((bbdb/mail-auto-create-p t)
 404     (bbdb-message-caching-enabled nil))
 405     (save-excursion
 406       (vm-select-folder-buffer)
 407       (bbdb/vm-pop-up-bbdb-buffer))))
 408
 409
 410 ;;;###autoload
 411 (defun bbdb-insinuate-vm ()
 412   "Call this function to hook BBDB into VM."
 413   (cond ((boundp 'vm-select-message-hook) ; VM 5.36+
 414      (add-hook 'vm-select-message-hook 'bbdb/vm-pop-up-bbdb-buffer))
 415     ((boundp 'vm-show-message-hook) ; VM 5.32.L+
 416      (add-hook 'vm-show-message-hook 'bbdb/vm-pop-up-bbdb-buffer))
 417     (t
 418      (error "vm versions older than 5.36 no longer supported")))
 419   (define-key vm-mode-map ":" 'bbdb/vm-show-sender)
 420    ;;  (define-key vm-mode-map "'" 'bbdb/vm-show-all-recipients) ;; not yet
 421   (define-key vm-mode-map ";" 'bbdb/vm-edit-notes)
 422   (define-key vm-mode-map "/" 'bbdb)
 423   ;; VM used to inherit from mail-mode-map, so bbdb-insinuate-sendmail
 424   ;; did this.  Kyle, you loser.
 425   (if (boundp 'vm-mail-mode-map)
 426       (define-key vm-mail-mode-map "\M-\t" 'bbdb-complete-name)))
 427
 428 (provide 'bbdb-vm)