home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-gnus.el < prev    next >
Encoding:
Text File  |  1992-09-08  |  6.7 KB  |  176 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; This file is part of the Insidious Big Brother Database (aka BBDB),
  4. ;;; copyright (c) 1991, 1992 Jamie Zawinski <jwz@lucid.com>.
  5. ;;; Interface to GNUS version 3.12 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 'gnus)
  24.  
  25. (defun bbdb/gnus-update-record (&optional offer-to-create)
  26.   "returns the record corresponding to the current GNUS message, creating 
  27. or modifying it as necessary.  A record will be created if 
  28. bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and
  29. the user confirms the creation."
  30.   (if bbdb-use-pop-up
  31.       (bbdb/gnus-pop-up-bbdb-buffer offer-to-create)
  32.     (let ((from
  33.        (progn
  34.          (set-buffer "*Article*")
  35.          (save-restriction
  36.            (widen)
  37.            ;;(gnus-Article-show-all-headers)
  38.            (narrow-to-region (point-min)
  39.                  (progn (goto-char (point-min))
  40.                     (or (search-forward "\n\n" nil t)
  41.                         (error "message unexists"))
  42.                     (- (point) 2)))
  43.            (mail-fetch-field "from")))))
  44.       (if from
  45.       (bbdb-annotate-message-sender from t
  46.                     (or (bbdb-invoke-hook-for-value
  47.                          bbdb/news-auto-create-p)
  48.                         offer-to-create)
  49.                     offer-to-create)))))
  50.  
  51. (defun bbdb/gnus-annotate-sender (string)
  52.   "Add a line to the end of the Notes field of the BBDB record 
  53. corresponding to the sender of this message."
  54.   (interactive (list (if bbdb-readonly-p
  55.              (error "The Insidious Big Brother Database is read-only.")
  56.              (read-string "Comments: "))))
  57.   (bbdb-annotate-notes (bbdb/gnus-update-record t) string))
  58.  
  59. (defun bbdb/gnus-edit-notes (&optional arg)
  60.   "Edit the notes field or (with a prefix arg) a user-defined field
  61. of the BBDB record corresponding to the sender of this message."
  62.   (interactive "P")
  63.   (let ((record (or (bbdb/gnus-update-record t) (error ""))))
  64.     (bbdb-display-records (list record))
  65.     (if arg
  66.     (bbdb-record-edit-property record nil t)
  67.       (bbdb-record-edit-notes record t))))
  68.  
  69. (defun bbdb/gnus-show-sender ()
  70.   "Display the contents of the BBDB for the sender of this message.
  71. This buffer will be in bbdb-mode, with associated keybindings."
  72.   (interactive)
  73.   (let ((record (bbdb/gnus-update-record t)))
  74.     (if record
  75.     (bbdb-display-records (list record))
  76.     (error "unperson"))))
  77.  
  78.  
  79. (defun bbdb/gnus-pop-up-bbdb-buffer (&optional offer-to-create)
  80.   "Make the *BBDB* buffer be displayed along with the GNUS windows,
  81. displaying the record corresponding to the sender of the current message."
  82.   (let ((bbdb-gag-messages t)
  83.     (bbdb-use-pop-up nil)
  84.     (bbdb-electric-p nil))
  85.     (let ((record (bbdb/gnus-update-record offer-to-create))
  86.       (bbdb-elided-display (bbdb-pop-up-elided-display))
  87.       (b (current-buffer)))
  88.       ;; display the bbdb buffer iff there is a record for this article.
  89.       (cond (record
  90.          (bbdb-pop-up-bbdb-buffer
  91.           (function (lambda (w)
  92.               (let ((b (current-buffer)))
  93.                 (set-buffer (window-buffer w))
  94.                 (prog1 (eq major-mode 'gnus-Article-mode)
  95.                    (set-buffer b))))))
  96.          (bbdb-display-records (list record)))
  97.         (t
  98.          (or bbdb-inside-electric-display
  99.          (not (get-buffer-window bbdb-buffer-name))
  100.          (let (w)
  101.            (delete-other-windows)
  102.            (gnus-configure-windows 'SelectArticle)
  103.            (if (setq w (get-buffer-window gnus-Subject-buffer))
  104.                (select-window w))
  105.            ))))
  106.       (set-buffer b)
  107.       record)))
  108.  
  109. (defvar bbdb/gnus-lines-and-from-length 18
  110.   "*The number of characters used to display From: info in GNUS, if you have
  111. set gnus-optional-headers to 'bbdb/gnus-lines-and-from.")
  112.  
  113. (defvar bbdb/gnus-header-prefer-real-names nil
  114.   "*If T, then the GNUS subject list will display real names instead of network
  115. addresses (gnus-optional-headers is 'bbdb/gnus-lines-and-from.)")
  116.  
  117. (defvar bbdb/gnus-mark-known-posters t
  118.   "*If T, then the GNUS subject list will contain an indication of those 
  119. messages posted by people who have entries in the Insidious Big Brother 
  120. Database (assuming gnus-optional-headers is 'bbdb/gnus-lines-and-from.)")
  121.  
  122. (defvar bbdb/gnus-header-show-bbdb-names t
  123.   "*If both this variable and bbdb/gnus-header-prefer-real-names are true,
  124. then for messages from folks who are in your database, the name displayed 
  125. will be the primary name in the database, rather than the one in the From
  126. line of the message.  This doesn't affect the names of people who aren't
  127. in the database, of course.  (gnus-optional-headers must be
  128. bbdb/gnus-lines-and-from.)")
  129.  
  130. (defun bbdb/gnus-lines-and-from (header)
  131.   "Useful as the value of gnus-optional-headers."
  132.   (let* ((length bbdb/gnus-lines-and-from-length)
  133.      (lines (nntp-header-lines header))
  134.      (from (nntp-header-from header))
  135.      (data (and (or bbdb/gnus-mark-known-posters
  136.             bbdb/gnus-header-show-bbdb-names)
  137.             (condition-case ()
  138.             (mail-extract-address-components from)
  139.               (error nil))))
  140.      (name (car data))
  141.      (net (car (cdr data)))
  142.      (record (and data 
  143.               (bbdb-search-simple name 
  144.                (if (and net bbdb-canonicalize-net-hook)
  145.                (bbdb-canonicalize-address net)
  146.              net))))
  147.      string L)
  148.       (setq name (or (and bbdb/gnus-header-prefer-real-names
  149.               (or (and bbdb/gnus-header-show-bbdb-names record
  150.                    (bbdb-record-name record))
  151.                   name))
  152.              net))
  153.       ;; GNUS can't cope with extra square-brackets appearing in the summary.
  154.       (if (and name (string-match "[][]" name))
  155.       (progn (setq name (copy-sequence name))
  156.          (while (string-match "[][]" name)
  157.            (aset name (match-beginning 0) ? ))))
  158.       (setq string (format "%c%3d:%s"
  159.                (if (and record bbdb/gnus-mark-known-posters) ?* ? )
  160.                lines (or name from))
  161.         L (length string))
  162.       (cond ((> L length) (substring string 0 length))
  163.         ((< L length) (concat string (make-string (- length L) ? )))
  164.         (t string))))
  165.  
  166. (defun bbdb-insinuate-gnus ()
  167.   "Call this function to hook BBDB into GNUS."
  168.   (bbdb-add-hook 'gnus-Article-prepare-hook 'bbdb/gnus-update-record)
  169.   (bbdb-add-hook 'gnus-Save-newsrc-hook 'bbdb-offer-save)
  170.   (setq gnus-optional-headers 'bbdb/gnus-lines-and-from)
  171.   (define-key gnus-Subject-mode-map ":" 'bbdb/gnus-show-sender)
  172.   (define-key gnus-Subject-mode-map ";" 'bbdb/gnus-edit-notes)
  173.   )
  174.  
  175. (provide 'bbdb-gnus)
  176.