home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-mhe.el < prev    next >
Encoding:
Text File  |  1992-09-08  |  9.0 KB  |  243 lines
  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;  Last modified:   8-sep-92. by jwz.
  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 'mh-e)    ; Note- we later redefine a function in this file.
  24.  
  25. (defmacro bbdb/mh-cache-key (message)
  26.   "Return a (numeric) key for MESSAGE"
  27.   ;; assumes message is a buffer-file-name like /usr/celine/Mail/inbox/2323,
  28.   ;;  and gets the 2323 from it.
  29.   (list 'string-to-int (list 'file-name-nondirectory message)))
  30.  
  31.  
  32. ;;;% Currently assumes msg buffer is the current buffer,
  33. ;;;% as usually (always?) is when called from the hook.
  34.  
  35. (defun bbdb/mh-update-record (&optional offer-to-create)
  36.   "Returns the record corresponding to the current MH message, creating or
  37. modifying it as necessary.  A record will be created if 
  38. bbdb/mail-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
  39. the user confirms the creation."
  40.   (if bbdb-use-pop-up
  41.       (bbdb/mh-pop-up-bbdb-buffer offer-to-create)
  42.     (if (and (boundp 'mh-show-buffer)
  43.          (bufferp mh-show-buffer)
  44.          (buffer-name mh-show-buffer)) ; not killed; gnus messes this up
  45.         (set-buffer mh-show-buffer))
  46.     (let ((msg (bbdb/mh-cache-key buffer-file-name)))
  47.       (if (eq msg 0) (setq msg nil))  ; 0 could mean trouble; be safe.
  48.       (or (bbdb-message-cache-lookup msg nil)  ; nil = current-buffer
  49.     (let ((from (bbdb/mh-get-field "^From[ \t]*:"))
  50.           name net)
  51.       (if (or (null from)
  52.           (string-match (bbdb-user-mail-names)
  53.                 (mail-strip-quoted-names from)))
  54.           ;; if logged-in user sent this, use recipients.
  55.           (setq from (or (bbdb/mh-get-field "^To[ \t]*:") from)))
  56.       (if from
  57.           (bbdb-encache-message msg
  58.             (bbdb-annotate-message-sender from t
  59.           (or (bbdb-invoke-hook-for-value bbdb/mail-auto-create-p)
  60.               offer-to-create)
  61.           offer-to-create))))))))
  62.  
  63.  
  64. (defun bbdb/mh-annotate-sender (string)
  65.   "Add a line to the end of the Notes field of the BBDB record 
  66. corresponding to the sender of this message."
  67.   (interactive (list (if bbdb-readonly-p
  68.              (error "The Insidious Big Brother Database is read-only.")
  69.              (read-string "Comments: "))))
  70.   (if (and (boundp 'mh-show-buffer) mh-show-buffer)
  71.       (set-buffer mh-show-buffer))
  72.   (bbdb-annotate-notes (bbdb/mh-update-record t) string))
  73.  
  74.  
  75. (defun bbdb/mh-edit-notes (&optional arg)
  76.   "Edit the notes field or (with a prefix arg) a user-defined field
  77. of the BBDB record corresponding to the sender of this message."
  78.   (interactive "P")
  79.   (let ((record (or (bbdb/mh-update-record t) (error ""))))
  80.     (bbdb-display-records (list record))
  81.     (if arg
  82.     (bbdb-record-edit-property record nil t)
  83.       (bbdb-record-edit-notes record t))))
  84.  
  85. (defun bbdb/mh-show-sender ()
  86.   "Display the contents of the BBDB for the sender of this message.
  87. This buffer will be in bbdb-mode, with associated keybindings."
  88.   (interactive)
  89.   (if (and (boundp 'mh-show-buffer) mh-show-buffer)
  90.       (set-buffer mh-show-buffer))
  91.   (let ((record (bbdb/mh-update-record t)))
  92.     (if record
  93.     (bbdb-display-records (list record))
  94.     (error "unperson"))))
  95.  
  96.  
  97. (defun bbdb/mh-pop-up-bbdb-buffer (&optional offer-to-create)
  98.   "Make the *BBDB* buffer be displayed along with the MH window,
  99. displaying the record corresponding to the sender of the current message."
  100.   (bbdb-pop-up-bbdb-buffer
  101.     (function (lambda (w)
  102.       (let ((b (current-buffer)))
  103.     (set-buffer (window-buffer w))
  104.     ;; I don't understand what this is supposed to do - tk
  105. ;       (prog1 (eq major-mode 'rmail-mode)       ; no such mode for show buffers... (match "^show" ..) ?
  106. ;       (set-buffer b))
  107.     ))))
  108.   (let ((bbdb-gag-messages t)
  109.     (bbdb-use-pop-up nil)
  110.     (bbdb-electric-p nil)
  111.     (saved-point (point)))
  112.     (let ((record (bbdb/mh-update-record offer-to-create))
  113.       (bbdb-elided-display (bbdb-pop-up-elided-display))
  114.       (b (current-buffer)))
  115.       (bbdb-display-records (if record (list record) nil))
  116.       (set-buffer b)
  117.       (goto-char saved-point)
  118.       record)
  119.   ))
  120.  
  121.  
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123. ;; mh-e modifictions --
  124. ;;   this now has a hook that gets called after we suck in the message.
  125.  
  126. ;; this is also called when you reply to a message
  127.  
  128. (defvar mh-show-message-hook ()
  129.   "Invoked after message is displayed in buffer.")
  130.  
  131. ;;; This has been modified to call mh-show-message-hook after setting up the message
  132. ;;;
  133. (defun mh-display-msg (msg-num folder)
  134.   ;; Display message NUMBER of FOLDER.
  135.   (set-buffer folder)
  136.   ;; Bind variables in folder buffer in case they are local
  137.   (let ((formfile mhl-formfile)
  138.     (clean-message-header mh-clean-message-header)
  139.     (invisible-headers mh-invisible-headers)
  140.     (visible-headers mh-visible-headers)
  141.     (msg-filename (mh-msg-filename msg-num))
  142.     (show-buffer mh-show-buffer)
  143.     (folder mh-current-folder))
  144.     (if (not (file-exists-p msg-filename))
  145.     (error "Message %d does not exist" msg-num))
  146.     (switch-to-buffer show-buffer)
  147.     (if mh-bury-show-buffer (bury-buffer (current-buffer)))
  148.     (mh-when (not (equal msg-filename buffer-file-name))
  149.       ;; Buffer does not yet contain message.
  150.       (clear-visited-file-modtime)
  151.       (unlock-buffer)
  152.       (setq buffer-file-name nil)    ; no locking during setup
  153.       (erase-buffer)
  154.       (if formfile
  155.       (if (stringp formfile)
  156.           (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
  157.                       "-form" formfile msg-filename)
  158.           (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
  159.                       msg-filename))
  160.       (insert-file-contents msg-filename))
  161.       (goto-char (point-min))
  162.       (cond (clean-message-header
  163.          (mh-clean-msg-header (point-min)
  164.                   invisible-headers
  165.                   visible-headers)
  166.          (goto-char (point-min)))
  167.         (t
  168.          (let ((case-fold-search t))
  169.            (re-search-forward
  170.         "^To:\\|^From:\\|^Subject:\\|^Date:" nil t)
  171.            (beginning-of-line)
  172.            (mh-recenter 0))))
  173.       (set-buffer-modified-p nil)
  174.       (setq buffer-file-name msg-filename)
  175.       (set-mark nil)
  176.       (setq mode-line-buffer-identification
  177.         (list (format mh-show-buffer-mode-line-buffer-id
  178.               folder msg-num)))))
  179.   (run-hooks 'mh-show-message-hook)
  180.   )
  181.  
  182. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  183. ;; this is a more strict version of mh-get-field which takes an regexp
  184.  
  185. (defun bbdb/mh-get-field (field)
  186.   ;; Find and return the value of field FIELD (regexp) in the current buffer.
  187.   ;; Returns the empty string if the field is not in the message.
  188.   (let ((case-fold-search nil))
  189.     (goto-char (point-min))
  190.     (cond ((not (re-search-forward field nil t)) "")
  191.       ((looking-at "[\t ]*$") "")
  192.       (t (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
  193.        (let ((field (buffer-substring (match-beginning 1) (match-end 1)))
  194.          (end-of-match (point)))
  195.          (forward-line)
  196.          (while (looking-at "[ \t]") (forward-line 1))
  197.          (backward-char 1)
  198.          (if (<= (point) end-of-match)
  199.          field
  200.          (format "%s%s" field
  201.              (buffer-substring end-of-match (point)))))))))
  202.  
  203. (defun bbdb/mh-execute-commands ()    
  204.   "Process outstanding delete and refile requests."
  205.   (interactive)    
  206.   (save-excursion
  207.     (set-buffer mh-show-buffer)
  208.     (setq bbdb-message-cache nil))
  209.   (bbdb-orig-mh-execute-commands))
  210.  
  211. (defun mh-send (to cc subject)
  212.   "Compose and send a letter."
  213.   (interactive (list
  214.         (bbdb-read-addresses-with-completion "To: ")
  215.         (bbdb-read-addresses-with-completion "Cc: ")
  216.         (read-string "Subject: ")))
  217.   (let ((config (current-window-configuration)))
  218.     (delete-other-windows)
  219.     (mh-send-sub to cc subject config)))
  220.  
  221. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  222. ;; mail from bbdb-mode using mh
  223.  
  224. ;; these redefine the bbdb-send-mail functions to use mh-send.
  225.  
  226. ;;; Install bbdb into mh-e's show-message function
  227.  
  228. (defun bbdb-insinuate-mh ()
  229.   "Call this function to hook BBDB into MH-E."
  230.   (define-key mh-folder-mode-map ":" 'bbdb/mh-show-sender)
  231.   (define-key mh-folder-mode-map ";" 'bbdb/mh-edit-notes)
  232.   (bbdb-add-hook 'mh-show-message-hook 'bbdb/mh-update-record)
  233.  
  234.   ;; We must patch into the "expunge" command to clear the cache, since
  235.   ;; expunging a message invalidates the cache (which is based on msg numbers).
  236.   (or (fboundp 'bbdb-orig-mh-execute-commands)
  237.       (fset 'bbdb-orig-mh-execute-commands 
  238.         (symbol-function 'mh-execute-commands)))
  239.   (fset 'mh-execute-commands 'bbdb/mh-execute-commands)
  240.   )
  241.  
  242. (provide 'bbdb-mhe)
  243.