-;;; -*- Mode:Emacs-Lisp -*-
+;; gnus-bbdb.el --- Interface to Semi-gnus
-;;; This file is part of Semi-gnus.
-;;; copyright (c) 1991, 1992, 1993 Jamie Zawinski <jwz@netscape.com>.
-;;; 1998 Keiichi Suzuki <kei-suzu@mail.wbs.ne.jp>
+;; 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>
-;;; 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 <kei-suzu@mail.wbs.ne.jp>
+;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Keywords: BBDB, MIME, multimedia, multilingual, mail, news
+
+;; This file is part of Semi-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 'gnus)
+(require 'std11)
(eval-when-compile
(require 'gnus-win))
+(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))
+
;;;###autoload
(defun gnus-bbdb/update-record (&optional offer-to-create)
"returns the record corresponding to the current GNUS message, creating
the user confirms the creation."
(if bbdb-use-pop-up
(gnus-bbdb/pop-up-bbdb-buffer offer-to-create)
- (let (from)
+ (save-excursion
(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.
+ (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)))
- (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)))))
+ (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
+ (bbdb-annotate-message-sender from t
+ (or (bbdb-invoke-hook-for-value
+ bbdb/news-auto-create-p)
+ offer-to-create)
+ offer-to-create)))))))
;;;###autoload
(defun gnus-bbdb/annotate-sender (string &optional replace)
(bbdb-display-records (list record))
(error "unperson"))))
+;; Avoid byte-compile warning.
+(defvar bbdb-pop-up-elided-display)
(defun gnus-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
"Make the *BBDB* buffer be displayed along with the GNUS windows,
(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)))
(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)))
"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))
;; 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))))
+ (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
projects / elisp / gnus.git- / blobdiff