X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-bbdb.el;h=35dd546b13ee98391a924d16774a2512c7975483;hb=5531e82e2b20eadd9c41fc50acfef7a2f736d5e5;hp=4c274ac4748f6023e6cb118e8ea84e3547e95544;hpb=83d8b53b0ecf90f5a8f541cb77bfacacd453815b;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-bbdb.el b/lisp/gnus-bbdb.el index 4c274ac..35dd546 100644 --- a/lisp/gnus-bbdb.el +++ b/lisp/gnus-bbdb.el @@ -1,67 +1,109 @@ -;;; -*- Mode:Emacs-Lisp -*- +;; gnus-bbdb.el --- Interface to T-gnus -;;; This file is part of Semi-gnus. -;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski . -;;; 1998 Keiichi Suzuki +;; Copyright (c) 1991,1992,1993 Jamie Zawinski . +;; Copyright (C) 1995,1996,1997 Shuhei KOBAYASHI +;; Copyright (C) 1997,1998 MORIOKA Tomohiko +;; Copyright (C) 1998,1999 Keiichi Suzuki -;;; 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. +;; Author: Keiichi Suzuki +;; Author: Shuhei KOBAYASHI +;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news + +;; This file is part of T-gnus. + +;; This program 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 2, or (at +;; your option) any later version. + +;; This program 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, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; 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 '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-name)) + ,field-body)) + +(defvar gnus-bbdb/extract-message-sender-function + 'gnus-bbdb/extract-message-sender) + +(defun gnus-bbdb/extract-message-sender () + (let ((from (mime-entity-fetch-field gnus-current-headers "from")) + to) + (when from + (setq from (gnus-bbdb/extract-address-components + (gnus-bbdb/decode-field-body from 'From))) + (if (and (car (cdr from)) + (string-match (bbdb-user-mail-names) (car (cdr from))) + ;; if logged-in user sent this, use recipients. + (setq to (mime-entity-fetch-field gnus-current-headers "to"))) + (gnus-bbdb/extract-address-components + (gnus-bbdb/decode-field-body to 'To)) + from)))) ;;;###autoload (defun gnus-bbdb/update-record (&optional offer-to-create) - "returns the record corresponding to the current GNUS message, creating -or modifying it as necessary. A record will be created if + "Return the record corresponding to the current GNUS message, creating +or modifying it as necessary. A record will be created if bbdb/news-auto-create-p is non-nil, or if OFFER-TO-CREATE is true and the user confirms the creation." (if bbdb-use-pop-up (gnus-bbdb/pop-up-bbdb-buffer offer-to-create) - (let (from) - (save-restriction - (set-buffer gnus-original-article-buffer) - (setq from (mail-header-from mime-message-structure)) - (when (or (null from) - (string-match (bbdb-user-mail-names) - (mail-strip-quoted-names from))) - ;; if logged-in user sent this, use recipients. - (widen) - (narrow-to-region (point-min) - (progn (goto-char (point-min)) - (or (search-forward "\n\n" nil t) - (error "message unexists")) - (- (point) 2))) - (let ((to (mail-fetch-field "to"))) - (setq from (mime-decode-field-body to 'To 'unfolding))))) - (when from - (bbdb-annotate-message-sender from t - (or (bbdb-invoke-hook-for-value - bbdb/news-auto-create-p) - offer-to-create) - offer-to-create))))) + (let ((message-key + (intern (mail-header-id gnus-current-headers))) + record sender) + (or (and (setq record (bbdb-message-cache-lookup message-key)) + (if (listp record) + (nth 1 record) + record)) + (when (setq sender + (funcall gnus-bbdb/extract-message-sender-function)) + (save-excursion + (setq record (bbdb-annotate-message-sender + sender t + (or (bbdb-invoke-hook-for-value + bbdb/news-auto-create-p) + offer-to-create) + offer-to-create))) + (when record + ;; XXX: BBDB 2.3x not only redefines + ;; `bbdb-encache-message' as a macro but also the inherent + ;; semantics of message caching functions is changed, so + ;; the following calls are much the same here. + (if (functionp 'bbdb-encache-message) + (car (bbdb-encache-message message-key (list record))) + (bbdb-encache-message message-key record)))))))) ;;;###autoload (defun gnus-bbdb/annotate-sender (string &optional replace) - "Add a line to the end of the Notes field of the BBDB record + "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: ")))) + (read-string "Comments: ")))) (bbdb-annotate-notes (gnus-bbdb/update-record t) string 'notes replace)) (defun gnus-bbdb/edit-notes (&optional arg) @@ -82,41 +124,126 @@ This buffer will be in bbdb-mode, with associated keybindings." (let ((record (gnus-bbdb/update-record t))) (if record (bbdb-display-records (list record)) - (error "unperson")))) + (error "unperson")))) (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-display-layout + (cond ((boundp 'bbdb-pop-up-display-layout) + (symbol-value 'bbdb-pop-up-display-layout)) + ((boundp 'bbdb-pop-up-elided-display) + (symbol-value 'bbdb-pop-up-elided-display)))) + (bbdb-elided-display bbdb-display-layout)) + (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-view-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))) + (if 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 @@ -139,8 +266,10 @@ This variable has no effect on the marking controlled by :group 'bbdb-mua-specific-gnus :type '(choice (const :tag "Mark known posters" t) (const :tag "Do not mark known posters" nil))) -(defvaralias 'gnus-bbdb/mark-known-posters - 'gnus-bbdb/summary-mark-known-posters) +(static-when (and (fboundp 'defvaralias) + (subrp (symbol-function 'defvaralias))) + (defvaralias 'gnus-bbdb/mark-known-posters + 'gnus-bbdb/summary-mark-known-posters)) (defcustom gnus-bbdb/summary-known-poster-mark "+" "This is the default character to prefix author names with if @@ -159,8 +288,10 @@ people who aren't in the database, of course. (`gnus-optional-headers' must be `gnus-bbdb/lines-and-from' for GNUS users.)" :group 'bbdb-mua-specific-gnus :type 'boolean) -(defvaralias 'gnus-bbdb/header-show-bbdb-names - 'gnus-bbdb/summary-show-bbdb-names) +(static-when (and (fboundp 'defvaralias) + (subrp (symbol-function 'defvaralias))) + (defvaralias 'gnus-bbdb/header-show-bbdb-names + 'gnus-bbdb/summary-show-bbdb-names)) (defcustom gnus-bbdb/summary-prefer-bbdb-data t "If t, then for posters who are in our BBDB, replace the information @@ -179,8 +310,10 @@ See `gnus-bbdb/lines-and-from' for GNUS users, or :group 'bbdb-mua-specific-gnus :type '(choice (const :tag "Prefer real names" t) (const :tag "Prefer network addresses" nil))) -(defvaralias 'gnus-bbdb/header-prefer-real-names - 'gnus-bbdb/summary-prefer-real-names) +(static-when (and (fboundp 'defvaralias) + (subrp (symbol-function 'defvaralias))) + (defvaralias 'gnus-bbdb/header-prefer-real-names + 'gnus-bbdb/summary-prefer-real-names)) (defcustom gnus-bbdb/summary-user-format-letter "B" "This is the gnus-user-format-function- that will be used to insert @@ -224,12 +357,13 @@ strings. In the future this should change." (data (and (or gnus-bbdb/summary-mark-known-posters gnus-bbdb/summary-show-bbdb-names) (condition-case () - (mail-extract-address-components from) + (gnus-bbdb/extract-address-components from) (error nil)))) (name (car data)) (net (car (cdr data))) - (record (and data - (bbdb-search-simple name + (record (and data + (bbdb-search-simple + name (if (and net bbdb-canonicalize-net-hook) (bbdb-canonicalize-address net) net)))) @@ -239,7 +373,7 @@ strings. In the future this should change." ;; bogon! (setq record nil)) - (setq name + (setq name (or (and gnus-bbdb/summary-prefer-bbdb-data (or (and gnus-bbdb/summary-prefer-real-names (and record (bbdb-record-name record))) @@ -250,22 +384,22 @@ strings. In the future this should change." net) name)) net from "**UNKNOWN**")) - ;; GNUS can't cope with extra square-brackets appearing in the summary. - (if (and name (string-match "[][]" name)) - (progn (setq name (copy-sequence name)) - (while (string-match "[][]" name) - (aset name (match-beginning 0) ? )))) - (setq string (format "%s%3d:%s" - (if (and record gnus-bbdb/summary-mark-known-posters) - (or (bbdb-record-getprop - record bbdb-message-marker-field) - "*") - " ") - lines (or name from)) - L (length string)) - (cond ((> L length) (substring string 0 length)) - ((< L length) (concat string (make-string (- length L) ? ))) - (t string)))) + ;; GNUS can't cope with extra square-brackets appearing in the summary. + (if (and name (string-match "[][]" name)) + (progn (setq name (copy-sequence name)) + (while (string-match "[][]" name) + (aset name (match-beginning 0) ? )))) + (setq string (format "%s%3d:%s" + (if (and record gnus-bbdb/summary-mark-known-posters) + (or (bbdb-record-getprop + record bbdb-message-marker-field) + "*") + " ") + lines (or name from)) + L (length string)) + (cond ((> L length) (substring string 0 length)) + ((< L length) (concat string (make-string (- length L) ? ))) + (t string)))) (defun gnus-bbdb/summary-get-author (header) "Given a Gnus message header, returns the appropriate piece of @@ -281,19 +415,20 @@ This function is meant to be used with the user function defined in (let* ((from (mail-header-from header)) (data (and gnus-bbdb/summary-show-bbdb-names (condition-case () - (mail-extract-address-components from) + (gnus-bbdb/extract-address-components from) (error nil)))) (name (car data)) (net (car (cdr data))) - (record (and data - (bbdb-search-simple name + (record (and data + (bbdb-search-simple + name (if (and net bbdb-canonicalize-net-hook) (bbdb-canonicalize-address net) net))))) (if (and record name (member (downcase name) (bbdb-record-net record))) ;; bogon! (setq record nil)) - (setq name + (setq name (or (and gnus-bbdb/summary-prefer-bbdb-data (or (and gnus-bbdb/summary-prefer-real-names (and record (bbdb-record-name record))) @@ -317,7 +452,7 @@ This function is meant to be used with the user function defined in "Given a Gnus message header, returns a mark if the poster is in the BBDB, \" \" otherwise. The mark itself is the value of the field indicated by `bbdb-message-marker-field' (`mark-char' by default) if the indicated field is in the poster's record, and `gnus-bbdb/summary-known-poster-mark' otherwise." (let* ((from (mail-header-from header)) (data (condition-case () - (mail-extract-address-components from) + (gnus-bbdb/extract-address-components from) (error nil))) (name (car data)) (net (cadr data)) @@ -379,12 +514,12 @@ field. This allows the BBDB to serve as a supplemental global score file, with the advantage that it can keep up with multiple and changing addresses better than the traditionally static global scorefile." (list (list - (condition-case nil - (read (gnus-bbdb/score-as-text group)) - (error (setq gnus-bbdb/score-rebuild-alist t) - (message "Problem building BBDB score table.") - (ding) (sit-for 2) - nil))))) + (condition-case nil + (read (gnus-bbdb/score-as-text group)) + (error (setq gnus-bbdb/score-rebuild-alist t) + (message "Problem building BBDB score table.") + (ding) (sit-for 2) + nil))))) (defun gnus-bbdb/score-as-text (group) "Returns a SCORE file format string built from the BBDB." @@ -393,38 +528,29 @@ addresses better than the traditionally static global scorefile." (setq gnus-bbdb/score-default-internal gnus-bbdb/score-default) t)) - (not gnus-bbdb/score-alist) - gnus-bbdb/score-rebuild-alist) - (setq gnus-bbdb/score-rebuild-alist nil) - (setq gnus-bbdb/score-alist - (concat "((touched nil) (\"from\"\n" - (mapconcat - (lambda (rec) - (let ((score (or (bbdb-record-getprop rec - gnus-bbdb/score-field) - gnus-bbdb/score-default)) - (net (bbdb-record-net rec))) - (if (not (and score net)) nil - (mapconcat - (lambda (addr) - (concat "(\"" addr "\" " score ")\n")) - net "")))) - (bbdb-records) "") - "))")))) + (not gnus-bbdb/score-alist) + gnus-bbdb/score-rebuild-alist) + (setq gnus-bbdb/score-rebuild-alist nil) + (setq gnus-bbdb/score-alist + (concat "((touched nil) (\"from\"\n" + (mapconcat + (lambda (rec) + (let ((score (or (bbdb-record-getprop + rec + gnus-bbdb/score-field) + gnus-bbdb/score-default)) + (net (bbdb-record-net rec))) + (if (not (and score net)) nil + (mapconcat + (lambda (addr) + (concat "(\"" addr "\" " score ")\n")) + net "")))) + (bbdb-records) "") + "))")))) 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 @@ -437,10 +563,52 @@ beginning of the message headers." ;; 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)) - (mime-decode-field-body value - (intern (capitalize field-name)) - 'unfolding)))) + (when (setq value (mime-entity-fetch-field + gnus-current-headers field-name)) + (gnus-bbdb/decode-field-body value field-name)))) + +;;; @ mail-extr +;;; + +(defvar gnus-bbdb/canonicalize-full-name-methods + '(gnus-bbdb/canonicalize-dots + gnus-bbdb/canonicalize-spaces)) + +(defun gnus-bbdb/extract-address-components (str) + (let* ((ret (std11-extract-address-components str)) + (phrase (car ret)) + (address (car (cdr ret))) + (methods gnus-bbdb/canonicalize-full-name-methods)) + (while (and phrase methods) + (setq phrase (funcall (car methods) phrase) + methods (cdr methods))) + (if (string= address "") (setq address nil)) + (if (string= phrase "") (setq phrase nil)) + (when (or phrase address) + (list phrase address)))) + +;;; @ full-name canonicalization methods +;;; + +(defun gnus-bbdb/canonicalize-spaces (str) + (let (dest) + (while (string-match "\\s +" str) + (setq dest (cons (substring str 0 (match-beginning 0)) dest)) + (setq str (substring str (match-end 0)))) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse 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)))) + (or (string= str "") + (setq dest (cons str dest))) + (setq dest (nreverse dest)) + (mapconcat 'identity dest " "))) ;; ;; Insinuation @@ -454,6 +622,7 @@ beginning of the message headers." (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-summary-exit-hook 'bbdb-flush-all-caches) (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) @@ -475,7 +644,7 @@ beginning of the message headers." Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter." gnus-bbdb/summary-user-format-letter)) (fset get-author-user-fun 'gnus-bbdb/summary-get-author)))) - + ; One tick. One tick only, please (cond (gnus-bbdb/summary-in-bbdb-format-letter (if (and (fboundp in-bbdb-user-fun) @@ -486,7 +655,7 @@ Please redefine `gnus-bbdb/summary-user-format-letter' to a different letter." Redefine `gnus-bbdb/summary-in-bbdb-format-letter' to a different letter." gnus-bbdb/summary-in-bbdb-format-letter)) (fset in-bbdb-user-fun 'gnus-bbdb/summary-author-in-bbdb))))) - + ;; Scoring (add-hook 'bbdb-after-change-hook 'gnus-bbdb/score-invalidate-alist) ; (setq gnus-score-find-score-files-function