diff options
author | Barak A. Pearlmutter <bap@debian.org> | 2010-04-20 15:18:13 -0400 |
---|---|---|
committer | Barak A. Pearlmutter <bap@debian.org> | 2010-04-20 15:18:13 -0400 |
commit | 0960d4900c9bc749cd72e3d928e8cfbe081712ea (patch) | |
tree | a9e6d9f90ba35dd7f1fdb68a96f08808380bfbbe /lisp/bbdb-vm.el |
Import bbdb_2.36.orig.tar.gz
[dgit import orig bbdb_2.36.orig.tar.gz]
Diffstat (limited to 'lisp/bbdb-vm.el')
-rw-r--r-- | lisp/bbdb-vm.el | 426 |
1 files changed, 426 insertions, 0 deletions
diff --git a/lisp/bbdb-vm.el b/lisp/bbdb-vm.el new file mode 100644 index 0000000..9ef279a --- /dev/null +++ b/lisp/bbdb-vm.el @@ -0,0 +1,426 @@ +;;; -*- Mode:Emacs-Lisp -*- + +;;; This file is the part of the Insidious Big Brother Database (aka BBDB), +;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>. +;;; Interface to VM (View Mail) 5.31 or greater. See bbdb.texinfo. + +;;; The Insidious Big Brother Database is free software; you can redistribute +;;; it and/or modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 1, or (at your +;;; option) any later version. +;;; +;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Emacs; see the file COPYING. If not, write to +;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +(eval-and-compile + (require 'cl) + (require 'bbdb) + (require 'bbdb-com) + (require 'bbdb-snarf) + (require 'vm-version) + (require 'vm-macro) + (require 'vm-message) + (require 'vm-misc) + (require 'vm-undo) + (require 'vm-motion) + (require 'vm-summary) + (require 'vm-vars) + (require 'vm-folder) + (require 'vm-mime)) + +(defun bbdb/vm-get-header-content (header-field msg) + (let ((content (vm-get-header-contents msg (concat header-field ":")))) + (if content + (vm-decode-mime-encoded-words-in-string content)))) + +(defcustom bbdb/vm-update-records-mode +; '(if (vm-new-flag msg) 'annotating 'searching) + 'annotating + "Controls how `bbdb/vm-update-records' processes email addresses. +Set this to an expression which evaluates either to 'searching or +'annotating. When set to 'annotating email addresses will be fed to +`bbdb-annotate-message-sender' in order to update existing records or create +new ones. A value of 'searching will search just for existing records having +the right net. + +The default is to annotate only new messages." + :group 'bbdb-mua-specific-vm + :type '(choice (const :tag "annotating all messages" + annotating) + (const :tag "annotating no messages" + searching) + (const :tag "annotating only new messages" + (if (vm-new-flag msg) 'annotating 'searching)) + (sexp :tag "user defined"))) + +;;;###autoload +(defun bbdb/vm-update-record (&optional offer-to-create) + (let* ((bbdb-get-only-first-address-p t) + (records (bbdb/vm-update-records offer-to-create))) + (if records (car records) nil))) + +;;;###autoload +(defun bbdb/vm-update-records (&optional offer-to-create) + "Returns the records corresponding to the current VM message, +creating or modifying them as necessary. A record will be created if +`bbdb/mail-auto-create-p' is non-nil or if OFFER-TO-CREATE is true, and +the user confirms the creation. + +The variable `bbdb/vm-update-records-mode' controls what actions +are performed and it might override `bbdb-update-records-mode'. + +When hitting C-g once you will not be asked anymore for new people listed +in this message, but it will search only for existing records. When hitting +C-g again it will stop scanning." + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-folder-empty) + (let ((msg (car vm-message-pointer)) + (enable-local-variables t) ; ...or vm bind this to nil. + (inhibit-quit nil) ; vm better not bind this to t! + (bbdb/vm-offer-to-create offer-to-create) + cache records) + + ;; ignore cache if we may be creating a record, since the cache + ;; may otherwise tell us that the user didn't want a record for + ;; this person. + (if (not bbdb/vm-offer-to-create) + (setq cache (and msg (bbdb-message-cache-lookup msg)))) + + (if cache + (setq records (if bbdb-get-only-first-address-p + (list (car cache)) + cache)) + + (let ((bbdb-update-records-mode (or bbdb/vm-update-records-mode + bbdb-update-records-mode))) + (setq records (bbdb-update-records + (bbdb-get-addresses bbdb-get-only-first-address-p + vm-summary-uninteresting-senders + 'bbdb/vm-get-header-content + (vm-real-message-of msg)) + bbdb/mail-auto-create-p + offer-to-create)) + + (bbdb-encache-message msg records))) + records)) + +;;;###autoload +(defun bbdb/vm-annotate-sender (string &optional replace) + "Add a line to the end of the Notes field of the BBDB record +corresponding to the sender of this message. If REPLACE is non-nil, +replace the existing notes entry (if any)." + (interactive + (list (if bbdb-readonly-p + (error "The Insidious Big Brother Database is read-only.") + (read-string "Comments: ")))) + (vm-follow-summary-cursor) + (let ((record (or (bbdb/vm-update-record t) (error "unperson")))) + (bbdb-annotate-notes record string 'notes replace))) + +(defun bbdb/vm-edit-notes (&optional arg) + "Edit the notes field or (with a prefix arg) a user-defined field +of the BBDB record corresponding to the sender of this message." + (interactive "P") + (vm-follow-summary-cursor) + (let ((record (or (bbdb/vm-update-record t) (error "unperson")))) + (bbdb-display-records (list record)) + (if arg + (bbdb-record-edit-property record nil t) + (bbdb-record-edit-notes record t)))) + +;;;###autoload +(defun bbdb/vm-show-records (&optional address-class) + "Display the contents of the BBDB for the sender of this message. +This buffer will be in bbdb-mode, with associated keybindings." + (interactive) + (vm-follow-summary-cursor) + (let ((bbdb-get-addresses-headers + (if address-class + (list (assoc address-class bbdb-get-addresses-headers)) + bbdb-get-addresses-headers)) + (bbdb/vm-update-records-mode 'annotating) + (bbdb-message-cache nil) + ;; should we move this to bbdb/vm-show-sender? + (bbdb-user-mail-names nil) + (vm-summary-uninteresting-senders nil) + records) + (setq records (bbdb/vm-update-records t)) + (if records + (bbdb-display-records records) + (bbdb-undisplay-records)) + records)) + +;;;###autoload +(defun bbdb/vm-show-all-recipients () + "Show all recipients of this message. Counterpart to `bbdb/vm-show-sender'." + (interactive) + (let ((bbdb-get-only-first-address-p nil)) + (bbdb/vm-show-records 'recipients))) + +;;;###autoload +(defun bbdb/vm-show-sender (&optional show-recipients) + "Display the contents of the BBDB for the senders of this message. +With a prefix argument show the recipients instead, +with two prefix arguments show all records. +This buffer will be in `bbdb-mode', with associated keybindings." + (interactive "p") + (cond ((= 4 show-recipients) + (bbdb/vm-show-all-recipients)) + ((= 16 show-recipients) + (let ((bbdb-get-only-first-address-p nil)) + (bbdb/vm-show-records))) + (t + (if (null (bbdb/vm-show-records 'authors)) + (bbdb/vm-show-all-recipients))))) + +(defun bbdb/vm-pop-up-bbdb-buffer (&optional offer-to-create) + "Make the *BBDB* buffer be displayed along with the VM window(s). +Displays the records corresponding to the sender respectively +recipients of the current message. +See `bbdb-get-addresses-headers' and 'bbdb-get-only-first-address-p' for +configuration of what is being displayed." + (save-excursion + (let ((bbdb-gag-messages t) + (bbdb-electric-p nil) + (records (bbdb/vm-update-records offer-to-create)) + (bbdb-buffer-name bbdb-buffer-name)) + + (when (and bbdb-use-pop-up records) + (bbdb-pop-up-bbdb-buffer + (function (lambda (w) + (let ((b (current-buffer))) + (set-buffer (window-buffer w)) + (prog1 (member major-mode '(vm-mode vm-presentation-mode)) + (set-buffer b)))))) + + ;; Always update the records; if there are no records, empty the + ;; BBDB window. This should be generic, not VM-specific. + (bbdb-display-records records bbdb-pop-up-display-layout)) + + (when (not records) + (bbdb-undisplay-records) + (if (get-buffer-window bbdb-buffer-name) + (delete-window (get-buffer-window bbdb-buffer-name))))))) + + +;; By Alastair Burt <burt@dfki.uni-kl.de> +;; vm 5.40 and newer support a new summary format, %U<letter>, to call +;; a user-provided function. Use "%-17.17UB" instead of "%-17.17F" to +;; have your VM summary buffers display BBDB's idea of the sender's full +;; name instead of the name (or lack thereof) in the message itself. + +(defun vm-summary-function-B (m &optional to-p) + "Given a VM message returns the BBDB name of the sender. +Respects vm-summary-uninteresting-senders." + (if (and vm-summary-uninteresting-senders (not to-p)) + (let ((case-fold-search nil)) + (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) + (concat vm-summary-uninteresting-senders-arrow + (vm-summary-function-B m t)) + (or (bbdb/vm-alternate-full-name (vm-su-from m)) + (vm-su-full-name m)))) + (or (bbdb/vm-alternate-full-name (if to-p (vm-su-to m) (vm-su-from m))) + (vm-decode-mime-encoded-words-in-string + (if to-p (vm-su-to-names m) (vm-su-full-name m)))))) + +(defun bbdb/vm-alternate-full-name (address) + (if address + (let ((entry (bbdb-search-simple + nil + (if (and address bbdb-canonicalize-net-hook) + (bbdb-canonicalize-address address) + address)))) + (if entry + (or (bbdb-record-getprop entry 'mail-name) + (bbdb-record-name entry)))))) + + +;; From: Mark Thomas <mthomas@jprc.com> +;; Subject: auto-folder-alist from bbdb + +;;;###autoload +(defcustom bbdb/vm-set-auto-folder-alist-field 'vm-folder + "*The field which `bbdb/vm-set-auto-folder-alist' searches for." + :group 'bbdb-mua-specific-vm + :type 'symbol) + +;;;###autoload +(defcustom bbdb/vm-set-auto-folder-alist-headers '("From:" "To:" "CC:") + "*The headers used by `bbdb/vm-set-auto-folder-alist'. +The order in this list is the order how matching will be performed!" + :group 'bbdb-mua-specific-vm + :type '(repeat (string :tag "header name"))) + +;;;###autoload +(defun bbdb/vm-set-auto-folder-alist () + "Create a `vm-auto-folder-alist' according to the records in the bbdb. +For each record that has a 'vm-folder' attribute, add an +element (email-regexp . folder) to the `vm-auto-folder-alist'. + +The element gets added to the 'element-name' sublist of the +`vm-auto-folder-alist'. + +The car of the element consists of all the email addresses for the +bbdb record concatenated with OR; the cdr is the value of the +vm-folder attribute. + +If the first character of vm-folders value is a quote ' it will be +parsed as lisp expression and is evaluated to return a folder name, +e.g. define you own function `my-folder-name' and set it to + '(my-folder-name)" + (interactive) + (let* (;; we add the email-address/vm-folder-name pair to this + ;; sublist of the vm-auto-folder-alist variable + (headers (reverse bbdb/vm-set-auto-folder-alist-headers)) + header + ;; grab the folder list from the vm-auto-folder-alist + folder-list + ;; the raw-notes and vm-folder attributes of the current bbdb + ;; record + notes-field folder + ;; a regexp matching all the email addresses from the bbdb + ;; record + email-regexp + ;; + records) + + (setq records + (delete + nil + (mapcar (lambda (r) + (if (bbdb-record-getprop r bbdb/vm-set-auto-folder-alist-field) + r)) + (bbdb-records)))) + + (while headers + (setq header (car headers) headers (cdr headers)) + ;; create the folder-list in vm-auto-folder-alist if it doesn't exist + (setq folder-list (assoc header vm-auto-folder-alist)) + (unless folder-list + (setq vm-auto-folder-alist (cons (list header) + vm-auto-folder-alist) + folder-list (assoc header vm-auto-folder-alist))) + (mapcar + (lambda (r) + (setq notes-field (bbdb-record-raw-notes r)) + (when (and (listp notes-field) + (setq folder (cdr (assq bbdb/vm-set-auto-folder-alist-field + notes-field)))) + ;; quote all the email addresses for the record and join them + ;; with OR + (setq email-regexp (regexp-opt (bbdb-record-net r))) + (unless (or (zerop (length email-regexp)) + (assoc email-regexp folder-list)) + ;; be careful: nconc modifies the list in place + (if (equal (elt folder 0) ?\') + (setq folder (read (substring folder 1)))) + (nconc folder-list (list (cons email-regexp folder)))))) + records)))) + + +;;; bbdb/vm-auto-add-label +;;; Howard Melman, contributed Jun 16 2000 +(defcustom bbdb/vm-auto-add-label-list nil + "*List used by `bbdb/vm-auto-add-label' to automatically label messages. +Each element in the list is either a string or a list of two strings. +If a single string then it is used as both the field value to check for +and the label to apply to the message. If a list of two strings, the first +is the field value to search for and the second is the label to apply." + :group 'bbdb-mua-specific-vm + :type 'list) + +(defcustom bbdb/vm-auto-add-label-field bbdb-define-all-aliases-field + "*Fields used by `bbdb/vm-auto-add-label' to automatically label messages. +Value is either a single symbol or a list of symbols of bbdb fields that +`bbdb/vm-auto-add-label' uses to check for labels to apply to messages. +Defaults to `bbdb-define-all-aliases-field' which is typically `mail-alias'." + :group 'bbdb-mua-specific-vm + :type '(choice symbol list)) + +(defun bbdb/vm-auto-add-label (record) + "Automatically add labels to messages based on the mail-alias field. +Add this to `bbdb-notice-hook' and if using VM each message that bbdb +notices will be checked. If the sender has a value in the +bbdb/vm-auto-add-label-field in their BBDB record that +matches a value in `bbdb/vm-auto-add-label-list' then a VM +label will be added to the message. + +This works great when `bbdb-user-mail-names' is set. As a result +mail that you send to people (and copy yourself on) is labeled as well. + +This is how you hook it in. +;; (add-hook 'bbdb-notice-hook 'bbdb/vm-auto-add-label) +" + (let (field aliases sep) + (and (eq major-mode 'vm-mode) + (mapcar #'(lambda(x) + (and + (setq field (bbdb-record-getprop record x)) + (setq sep (or (get x 'field-separator) ",")) + (setq aliases (append aliases (bbdb-split field sep))))) + (cond ((listp bbdb/vm-auto-add-label-field) + bbdb/vm-auto-add-label-field) + ((symbolp bbdb/vm-auto-add-label-field) + (list bbdb/vm-auto-add-label-field)) + (t (error "Bad value for bbdb/vm-auto-add-label-field")) + )) + (vm-add-message-labels + (mapconcat #'(lambda (l) + (cond ((stringp l) + (if (member l aliases) + l)) + ((and (consp l) + (stringp (car l)) + (stringp (cdr l))) + (if (member (car l) aliases) + (cdr l))) + (t + (error "Malformed bbdb/vm-auto-add-label-list") + ))) + bbdb/vm-auto-add-label-list + " ") + 1)))) + + +;;; Automatically add a record for replies. +;;; Contributed by Robert Fenk, 27 Oct 2000. It only took me 8 months to put +;;; it in the source... +;;; +;;; (add-hook 'vm-reply-hook 'bbdb/vm-force-create) to enable it. You could +;;; presumably hook it elsewhere as well. +(defun bbdb/vm-force-create () + "Force automatic adding of a bbdb entry for current message." + (interactive) + (let ((bbdb/mail-auto-create-p t) + (bbdb-message-caching-enabled nil)) + (save-excursion + (vm-select-folder-buffer) + (bbdb/vm-pop-up-bbdb-buffer)))) + + +;;;###autoload +(defun bbdb-insinuate-vm () + "Call this function to hook BBDB into VM." + (cond ((boundp 'vm-select-message-hook) ; VM 5.36+ + (add-hook 'vm-select-message-hook 'bbdb/vm-pop-up-bbdb-buffer)) + ((boundp 'vm-show-message-hook) ; VM 5.32.L+ + (add-hook 'vm-show-message-hook 'bbdb/vm-pop-up-bbdb-buffer)) + (t + (error "vm versions older than 5.36 no longer supported"))) + (define-key vm-mode-map ":" 'bbdb/vm-show-sender) + ;; (define-key vm-mode-map "'" 'bbdb/vm-show-all-recipients) ;; not yet + (define-key vm-mode-map ";" 'bbdb/vm-edit-notes) + (define-key vm-mode-map "/" 'bbdb) + ;; VM used to inherit from mail-mode-map, so bbdb-insinuate-sendmail + ;; did this. Kyle, you loser. + (if (boundp 'vm-mail-mode-map) + (define-key vm-mail-mode-map "\M-\t" 'bbdb-complete-name))) + +(provide 'bbdb-vm) |