home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-vm.el < prev    next >
Encoding:
Text File  |  1992-09-08  |  5.8 KB  |  148 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
  4. ;;; copyright (c) 1991, 1992 Jamie Zawinski <jwz@lucid.com>.
  5. ;;; Interface to VM (View Mail) 5.31 or greater.  See bbdb.texinfo.
  6. ;;; last change  8-sep-92.
  7.  
  8. ;;; The Insidious Big Brother Database is free software; you can redistribute
  9. ;;; it and/or modify it under the terms of the GNU General Public License as
  10. ;;; published by the Free Software Foundation; either version 1, or (at your
  11. ;;; option) any later version.
  12. ;;;
  13. ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  14. ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  15. ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  16. ;;; details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  20. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. (require 'bbdb)
  23. (require 'vm)
  24. ;(require 'vm-motion) ; not provided, dammit!
  25. ;(require 'vm-summary)
  26. (if (not (fboundp 'vm-record-and-change-message-pointer)) (load-library "vm-motion"))
  27. (if (not (fboundp 'vm-su-from)) (load-library "vm-summary"))
  28. (or (boundp 'vm-mode-map) (load-library "vm-vars"))
  29.  
  30. (defun bbdb/vm-update-record (&optional offer-to-create)
  31.   "returns the record corresponding to the current VM message, creating or
  32. modifying it as necessary.  A record will be created if 
  33. bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
  34. the user confirms the creation."
  35.   (save-excursion
  36.   (and vm-mail-buffer (set-buffer vm-mail-buffer))
  37.   (if bbdb-use-pop-up
  38.       (bbdb/vm-pop-up-bbdb-buffer offer-to-create)
  39.     (let ((msg (car vm-message-pointer))
  40.       (inhibit-local-variables nil)    ; vm binds this to t...
  41.       (enable-local-variables t)    ; ...or vm bind this to nil.
  42.       (inhibit-quit nil))    ; vm damn well better not bind this to t!
  43.       ;; this doesn't optimize the case of moving thru a folder where
  44.       ;; few messages have associated records.
  45.       (or (bbdb-message-cache-lookup msg nil)  ; nil = current-buffer
  46.       (and msg
  47.         ;; ## Note: once VM uses mail-extr.el, we should just get the
  48.         ;; ## name and address from `vm-su-full-name' and `vm-su-from'
  49.         ;; ## instead of parsing it again here.
  50.         (save-excursion
  51.           (save-restriction
  52.         (widen)
  53.         (narrow-to-region (vm-start-of (car vm-message-pointer))
  54.                   (vm-end-of (car vm-message-pointer)))
  55.         (let ((from (mail-fetch-field "from")))
  56.           (if (or (null from)
  57.               (string-match (bbdb-user-mail-names)
  58.                 ;; mail-strip-quoted-names is too broken!
  59.                 ;;(mail-strip-quoted-names from)
  60.                 (car (cdr (mail-extract-address-components
  61.                        from)))))
  62.               ;; if logged in user sent this, use recipients.
  63.               (setq from (or (mail-fetch-field "to") from)))
  64.           (if from
  65.               (bbdb-encache-message msg
  66.             (bbdb-annotate-message-sender from t
  67.               (or (bbdb-invoke-hook-for-value
  68.                    bbdb/mail-auto-create-p)
  69.                   offer-to-create)
  70.               offer-to-create))))))))))))
  71.  
  72. (defun bbdb/vm-annotate-sender (string)
  73.   "Add a line to the end of the Notes field of the BBDB record 
  74. corresponding to the sender of this message."
  75.   (interactive (list (if bbdb-readonly-p
  76.              (error "The Insidious Big Brother Database is read-only.")
  77.              (read-string "Comments: "))))
  78.   (vm-follow-summary-cursor)
  79.   (bbdb-annotate-notes (bbdb/vm-update-record t) string))
  80.  
  81.  
  82. (defun bbdb/vm-edit-notes (&optional arg)
  83.   "Edit the notes field or (with a prefix arg) a user-defined field
  84. of the BBDB record corresponding to the sender of this message."
  85.   (interactive "P")
  86.   (vm-follow-summary-cursor)
  87.   (let ((record (or (bbdb/vm-update-record t) (error ""))))
  88.     (bbdb-display-records (list record))
  89.     (if arg
  90.     (bbdb-record-edit-property record nil t)
  91.       (bbdb-record-edit-notes record t))))
  92.  
  93. (defun bbdb/vm-show-sender ()
  94.   "Display the contents of the BBDB for the sender of this message.
  95. This buffer will be in bbdb-mode, with associated keybindings."
  96.   (interactive)
  97.   (vm-follow-summary-cursor)
  98.   (let ((record (bbdb/vm-update-record t)))
  99.     (if record
  100.     (bbdb-display-records (list record))
  101.     (error "unperson"))))
  102.  
  103.  
  104. (defun bbdb/vm-pop-up-bbdb-buffer (&optional offer-to-create)
  105.   "Make the *BBDB* buffer be displayed along with the VM window(s),
  106. displaying the record corresponding to the sender of the current message."
  107.   (bbdb-pop-up-bbdb-buffer
  108.     (function (lambda (w)
  109.       (let ((b (current-buffer)))
  110.     (set-buffer (window-buffer w))
  111.     (prog1 (eq major-mode 'vm-mode)
  112.       (set-buffer b))))))
  113.   (let ((bbdb-gag-messages t)
  114.     (bbdb-use-pop-up nil)
  115.     (bbdb-electric-p nil))
  116.     (let ((record (bbdb/vm-update-record offer-to-create))
  117.       (bbdb-elided-display (bbdb-pop-up-elided-display))
  118.       (b (current-buffer)))
  119.       (bbdb-display-records (if record (list record) nil))
  120.       (set-buffer b)
  121.       record)))
  122.  
  123. (defun bbdb/vm-record-and-change-message-pointer (old new)
  124.   (prog1 (bbdb-orig-vm-record-and-change-message-pointer old new)
  125.     (bbdb/vm-update-record nil)))
  126.  
  127. (defun bbdb-insinuate-vm ()
  128.   "Call this function to hook BBDB into VM."
  129.   (cond ((boundp 'vm-show-message-hook)
  130.      (bbdb-add-hook 'vm-show-message-hook 'bbdb/vm-update-record)
  131.      ;; Here too?  I don't use preview, so I don't know if this would win.
  132.      ;(bbdb-add-hook 'vm-preview-message-hook 'bbdb/vm-update-record)
  133.      )
  134.     (t
  135.      ;; Hack on to vm-record-and-change-message-pointer, since VM 5.32
  136.      ;; doesn't have vm-show-message-hook.
  137.      (or (fboundp 'bbdb-orig-vm-record-and-change-message-pointer)
  138.          (fset 'bbdb-orig-vm-record-and-change-message-pointer
  139.            (symbol-function 'vm-record-and-change-message-pointer)))
  140.      (fset 'vm-record-and-change-message-pointer
  141.            (symbol-function 'bbdb/vm-record-and-change-message-pointer))
  142.      ))
  143.   (define-key vm-mode-map ":" 'bbdb/vm-show-sender)
  144.   (define-key vm-mode-map ";" 'bbdb/vm-edit-notes)
  145.   )
  146.  
  147. (provide 'bbdb-vm)
  148.