-;; gnus-bbdb.el --- Interface to Semi-gnus.
+;; gnus-bbdb.el --- Interface to after Nana-gnus version 6.10.2.
;; Copyright (c) 1991,1992,1993 Jamie Zawinski <jwz@netscape.com>.
;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI
;; Copyright (C) 1997,1998 MORIOKA Tomohiko
-;; Copyright (C) 1998 Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Copyright (C) 1998,1999 Keiichi Suzuki <keiichi@nanap.org>
-;; Author: Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; Author: Keiichi Suzuki <keiichi@nanap.org>
;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
-;; This file is part of Semi-gnus.
+;; This file is part of Nana-gnus.
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;;; Code:
(require 'bbdb)
+(require 'bbdb-com)
(require 'gnus)
(require 'std11)
(eval-when-compile
- (require 'gnus-win))
+ (defvar bbdb-pop-up-elided-display) ; default unbound.
+ (require 'gnus-win)
+ (require 'cl))
-(defvar gnus-bbdb/decode-field-body-function 'eword-decode-string
+(eval-after-load "gnus-cus"
+ '(add-to-list 'gnus-user-group-parameters
+ '(bbdb-auto-create-p
+ (const :tag "Auto register address to BBDB" t)
+ "Create new bbdb records people you receive mail from.")))
+
+(defvar gnus-bbdb/decode-field-body-function 'nnheader-decode-field-body
"*Field body decoder.")
(defmacro gnus-bbdb/decode-field-body (field-body field-name)
`(or (and (functionp gnus-bbdb/decode-field-body-function)
(funcall gnus-bbdb/decode-field-body-function
- ,field-body))
+ ,field-body ,field-name))
,field-body))
;;;###autoload
the user confirms the creation."
(if bbdb-use-pop-up
(gnus-bbdb/pop-up-bbdb-buffer offer-to-create)
- (save-excursion
- (save-restriction
- (let (from)
- (set-buffer gnus-original-article-buffer)
- (widen)
- (narrow-to-region (point-min)
- (progn (goto-char (point-min))
- (or (search-forward "\n\n" nil t)
- (error "message unexists"))
- (- (point) 2)))
- (when (setq from (mail-fetch-field "from"))
- (setq from (gnus-bbdb/extract-address-components
- (gnus-bbdb/decode-field-body from 'From))))
- (when (and (car (cdr from))
- (string-match (bbdb-user-mail-names)
- (car (cdr from))))
- ;; if logged-in user sent this, use recipients.
- (let ((to (mail-fetch-field "to")))
- (when to
- (setq from
- (gnus-bbdb/extract-address-components
- (gnus-bbdb/decode-field-body to 'To))))))
- (when from
+ (let ((from (mime-entity-fetch-field gnus-current-headers "from")))
+ (when from
+ (setq from (gnus-bbdb/extract-address-components
+ (gnus-bbdb/decode-field-body from 'From))))
+ (when (and (car (cdr from))
+ (string-match (bbdb-user-mail-names) (car (cdr from))))
+ ;; if logged-in user sent this, use recipients.
+ (let ((to (mime-entity-fetch-field gnus-current-headers "to")))
+ (when to
+ (setq from
+ (gnus-bbdb/extract-address-components
+ (gnus-bbdb/decode-field-body to 'To))))))
+ (when from
+ (save-excursion
(bbdb-annotate-message-sender from t
(or (bbdb-invoke-hook-for-value
bbdb/news-auto-create-p)
offer-to-create)
- offer-to-create)))))))
+ offer-to-create))))))
;;;###autoload
(defun gnus-bbdb/annotate-sender (string &optional replace)
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: "))))
+ (read-string "Comments: "))))
(bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace))
(defun gnus-bbdb/edit-notes (&optional arg)
(bbdb-record-edit-property record nil t)
(bbdb-record-edit-notes record t))))
+(defun gnus-bbdb/ignore-sender (func &optional arglist)
+ (let* ((from (mime-entity-fetch-field gnus-current-headers "from"))
+ (bbdb-user-mail-names
+ (when from
+ (regexp-quote
+ (car (cdr (gnus-bbdb/extract-address-components
+ (gnus-bbdb/decode-field-body from 'From))))))))
+ (apply func arglist)))
+
+;;;###autoload
+(defun gnus-bbdb/edit-notes-to (&optional arg)
+ "Edit the notes field or (with a prefix arg) a user-defined field
+of the BBDB record corresponding to the primary recipient of this message."
+ (interactive "P")
+ (gnus-bbdb/ignore-sender 'gnus-bbdb/edit-notes (list arg)))
+
;;;###autoload
(defun gnus-bbdb/show-sender ()
"Display the contents of the BBDB for the sender of this message.
(bbdb-display-records (list record))
(error "unperson"))))
+;;;###autoload
+(defun gnus-bbdb/show-to ()
+ "Display the contents of the BBDB for the primary recipient of this message.
+This buffer will be in bbdb-mode, with associated keybindings."
+ (interactive)
+ (gnus-bbdb/ignore-sender 'gnus-bbdb/show-sender))
(defun gnus-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
"Make the *BBDB* buffer be displayed along with the GNUS windows,
displaying the record corresponding to the sender of the current message."
- (let ((bbdb-gag-messages t)
- (bbdb-use-pop-up nil)
- (bbdb-electric-p nil))
- (let ((record (gnus-bbdb/update-record offer-to-create))
- (bbdb-elided-display (bbdb-pop-up-elided-display))
- (b (current-buffer)))
+ (let* ((bbdb-gag-messages t)
+ (bbdb-electric-p nil)
+ (record (let (bbdb-use-pop-up)
+ (gnus-bbdb/update-record offer-to-create)))
+ (bbdb-elided-display (bbdb-pop-up-elided-display)))
+ (save-current-buffer
;; display the bbdb buffer iff there is a record for this article.
- (cond (record
- (bbdb-pop-up-bbdb-buffer
- (function (lambda (w)
- (let ((b (current-buffer)))
- (set-buffer (window-buffer w))
- (prog1 (or (eq major-mode 'mime-veiw-mode)
- (eq major-mode 'gnus-article-mode))
- (set-buffer b))))))
- (bbdb-display-records (list record)))
- (t
- (or bbdb-inside-electric-display
- (not (get-buffer-window bbdb-buffer-name))
- (let (w)
- (delete-other-windows)
- (if (assq 'article gnus-buffer-configuration)
- (gnus-configure-windows 'article)
- (gnus-configure-windows 'SelectArticle))
- (if (setq w (get-buffer-window gnus-summary-buffer))
- (select-window w))
- ))))
- (set-buffer b)
- record)))
+ (cond
+ (record
+ (bbdb-pop-up-bbdb-buffer
+ (lambda (w)
+ (with-current-buffer (window-buffer w)
+ (memq major-mode '(mime-veiw-mode gnus-article-mode)))))
+ (bbdb-display-records (list record)))
+ ((and (not bbdb-inside-electric-display)
+ (get-buffer-window bbdb-buffer-name))
+ (delete-other-windows)
+ (if (assq 'article gnus-buffer-configuration)
+ (gnus-configure-windows 'article)
+ (gnus-configure-windows 'SelectArticle))
+ (let ((w (get-buffer-window gnus-summary-buffer)))
+ (when w
+ (select-window w))))))
+ record))
+
+;;;###autoload
+(defun gnus-bbdb/split-mail (header-field bbdb-field
+ &optional regexp group)
+ "Mail split method for `nnmail-split-fancy'.
+HEADER-FIELD is a regexp or list of regexps as mail header field name
+for gathering mail addresses. If HEADER-FIELD is a string, then it's
+used for just matching pattern. If HEADER-FIELD is a list of strings,
+then these strings have priorities in the order.
+
+BBDB-FIELD is field name of BBDB.
+Optional argument REGEXP is regexp string for matching BBDB-FIELD value.
+If REGEXP is nil or not specified, then all BBDB-FIELD value is matched.
+
+If GROUP is nil or not specified, then BBDB-FIELD value is returned as
+group name. If GROUP is a symbol `&', then list of all matching group's
+BBDB-FIELD values is returned. Otherwise, GROUP is returned."
+ (if (listp header-field)
+ (if (eq group '&)
+ (gnus-bbdb/split-mail (mapconcat 'identity header-field "\\|")
+ bbdb-field regexp group)
+ (let (rest)
+ (while (and header-field
+ (null (setq rest (gnus-bbdb/split-mail
+ (car header-field) bbdb-field
+ regexp group))))
+ (setq header-field (cdr header-field)))
+ rest))
+ (let ((pat (concat "^\\(" header-field "\\):[ \t]"))
+ header-values)
+ (goto-char (point-min))
+ (while (re-search-forward pat nil t)
+ (setq header-values (cons (buffer-substring (point)
+ (std11-field-end))
+ header-values)))
+ (let ((address-regexp
+ (with-temp-buffer
+ (let (lal)
+ (while header-values
+ (setq lal (std11-parse-addresses-string
+ (pop header-values)))
+ (while lal
+ (gnus-bbdb/insert-address-regexp (pop lal)))))
+ (buffer-string))))
+ (unless (zerop (length address-regexp))
+ (gnus-bbdb/split-mail-1 address-regexp bbdb-field regexp group))))))
+
+(defun gnus-bbdb/insert-address-regexp (address)
+ "Insert string of address part from parsed ADDRESS of RFC 822."
+ (cond ((eq (car address) 'group)
+ (setq address (cdr address))
+ (while address
+ (gnus-bbdb/insert-address-regexp (pop address))))
+ ((eq (car address) 'mailbox)
+ (unless (eq (point) (point-min))
+ (insert "\\|"))
+ (let ((addr (nth 1 address)))
+ (insert (regexp-quote (std11-addr-to-string
+ (if (eq (car addr) 'phrase-route-addr)
+ (nth 2 addr)
+ (cdr addr)))))))))
+
+(defun gnus-bbdb/split-mail-1 (address-regexp bbdb-field regexp group)
+ (let ((records (bbdb-search (bbdb-records) nil nil address-regexp))
+ prop rest)
+ (or regexp (setq regexp ""))
+ (catch 'done
+ (cond
+ ((eq group '&)
+ (while records
+ (when (and (setq prop (bbdb-record-getprop (car records) bbdb-field))
+ (string-match regexp prop)
+ (not (member prop rest)))
+ (setq rest (cons prop rest)))
+ (setq records (cdr records)))
+ (throw 'done (when rest (cons '& rest))))
+ (t
+ (while records
+ (when (or (null bbdb-field)
+ (and (setq prop (bbdb-record-getprop (car records)
+ bbdb-field))
+ (string-match regexp prop)))
+ (throw 'done (or group prop)))
+ (setq records (cdr records))))))))
;;
;; Announcing BBDB entries in the summary buffer
gnus-bbdb/score-alist)
(defun gnus-bbdb/extract-field-value-init ()
- (when (or (and (eq (current-buffer) (get-buffer gnus-article-buffer))
- (buffer-live-p gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer))
- (eq (current-buffer) (get-buffer gnus-original-article-buffer)))
- (widen)
- (narrow-to-region (point-min)
- (progn (goto-char (point-min))
- (or (search-forward "\n\n" nil t)
- (error "message unexists"))
- (- (point) 2)))
- 'gnus-bbdb/extract-field-value))
+ (function gnus-bbdb/extract-field-value))
(defun gnus-bbdb/extract-field-value (field-name)
"Given the name of a field (like \"Subject\") this returns the value of
;; we can't special-case VM here to use its cache, because the cache has
;; divided real-names from addresses; the actual From: and Subject: fields
;; exist only in the message.
- (let (value)
- (when (setq value (mail-fetch-field field-name))
+ (let ((value (mime-entity-fetch-field gnus-current-headers field-name)))
+ (when value
(gnus-bbdb/decode-field-body value field-name))))
;;; @ mail-extr
(if (string= address "") (setq address nil))
(if (string= phrase "") (setq phrase nil))
(when (or phrase address)
- (list phrase address))
- ))
+ (list phrase address))))
;;; @ full-name canonicalization methods
;;;
(let (dest)
(while (string-match "\\s +" str)
(setq dest (cons (substring str 0 (match-beginning 0)) dest))
- (setq str (substring str (match-end 0)))
- )
+ (setq str (substring str (match-end 0))))
(or (string= str "")
(setq dest (cons str dest)))
(setq dest (nreverse dest))
- (mapconcat 'identity dest " ")
- ))
+ (mapconcat 'identity dest " ")))
(defun gnus-bbdb/canonicalize-dots (str)
(let (dest)
(while (string-match "\\." str)
(setq dest (cons (substring str 0 (match-end 0)) dest))
- (setq str (substring str (match-end 0)))
- )
+ (setq str (substring str (match-end 0))))
(or (string= str "")
(setq dest (cons str dest)))
(setq dest (nreverse dest))
- (mapconcat 'identity dest " ")
- ))
+ (mapconcat 'identity dest " ")))
+
+(defun gnus-bbdb/article-prepare-hook ()
+ (let ((bbdb/news-auto-create-p (gnus-group-find-parameter
+ (with-current-buffer
+ gnus-article-current-summary
+ gnus-newsgroup-name)
+ 'bbdb-auto-create-p)))
+ (gnus-bbdb/update-record)))
;;
;; Insinuation
(when (boundp 'bbdb-extract-field-value-function-list)
(add-to-list 'bbdb-extract-field-value-function-list
'gnus-bbdb/extract-field-value-init))
- (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/update-record)
+ (add-hook 'gnus-article-prepare-hook 'gnus-bbdb/article-prepare-hook)
(add-hook 'gnus-save-newsrc-hook 'bbdb-offer-save)
(define-key gnus-summary-mode-map ":" 'gnus-bbdb/show-sender)
(define-key gnus-summary-mode-map ";" 'gnus-bbdb/edit-notes)
+ (define-key gnus-summary-mode-map "[" 'gnus-bbdb/show-to)
+ (define-key gnus-summary-mode-map "]" 'gnus-bbdb/edit-notes-to)
;; Set up user field for use in gnus-summary-line-format
(let ((get-author-user-fun (intern
projects / elisp / gnus.git- / blobdiff