Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-bbdb.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 4b173ad71786
children 54cc21c15cbb
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
4 ;; Copyright (C) 1996 Artur Pioro 4 ;; Copyright (C) 1996 Artur Pioro
5 5
6 ;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> 6 ;; Author: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
7 ;; Artur Pioro <artur@flugor.if.uj.edu.pl> 7 ;; Artur Pioro <artur@flugor.if.uj.edu.pl>
8 ;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp> 8 ;; Maintainer: Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
9 ;; Version: $Id: tm-bbdb.el,v 1.2 1996/12/22 00:29:37 steve Exp $ 9 ;; Version: $Id: tm-bbdb.el,v 1.1.1.1 1996/12/18 22:43:38 steve Exp $
10 ;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB 10 ;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB
11 11
12 ;; This file is part of tm (Tools for MIME). 12 ;; This file is part of tm (Tools for MIME).
13 13
14 ;; This program is free software; you can redistribute it and/or 14 ;; This program is free software; you can redistribute it and/or
26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA. 27 ;; Boston, MA 02111-1307, USA.
28 28
29 ;;; Code: 29 ;;; Code:
30 30
31 (eval-when (compile)
32 (ignore-errors
33 (require 'bbdb)
34 (require 'bbdb-com)))
35 (eval-when (load eval)
36 (require 'bbdb)
37 (require 'bbdb-com))
31 (require 'std11) 38 (require 'std11)
32 (require 'tm-ew-d) 39 (require 'tm-ew-d)
33 (require 'tm-view) 40 (require 'tm-view)
34 (if (module-installed-p 'bbdb-com) 41
35 (require 'bbdb-com)
36 (eval-when-compile
37 ;; imported from bbdb-1.51
38 (defmacro bbdb-pop-up-elided-display ()
39 '(if (boundp 'bbdb-pop-up-elided-display)
40 bbdb-pop-up-elided-display
41 bbdb-elided-display))
42 (defmacro bbdb-user-mail-names ()
43 "Returns a regexp matching the address of the logged-in user"
44 '(or bbdb-user-mail-names
45 (setq bbdb-user-mail-names
46 (concat "\\b" (regexp-quote (user-login-name)) "\\b"))))
47 ))
48
49
50 ;;; @ User Variables
51 ;;;
52
53 (defvar tm-bbdb/use-mail-extr t
54 "*If non-nil, `mail-extract-address-components' is used.
55 Otherwise `tm-bbdb/extract-address-components' overrides it.")
56
57 (defvar tm-bbdb/auto-create-p nil
58 "*If t, create new BBDB records automatically.
59 If function, then it is called with no arguments to decide whether an
60 entry should be automatically creaded.
61
62 tm-bbdb uses this variable instead of `bbdb/mail-auto-create-p' or
63 `bbdb/news-auto-create-p' unless other tm-MUA overrides it.")
64
65 (defvar tm-bbdb/delete-empty-window nil
66 "*If non-nil, delete empty BBDB window.
67 All bbdb-MUAs but bbdb-gnus display BBDB window even if it is empty.
68 If you prefer behavior of bbdb-gnus, set this variable to t.
69
70 For framepop users: If empty, `framepop-banish' is used instead.")
71 42
72 ;;; @ mail-extr 43 ;;; @ mail-extr
73 ;;; 44 ;;;
45
46 (defvar tm-bbdb/use-mail-extr t)
74 47
75 (defun tm-bbdb/extract-address-components (str) 48 (defun tm-bbdb/extract-address-components (str)
76 (let* ((ret (std11-extract-address-components str)) 49 (let* ((ret (std11-extract-address-components str))
77 (phrase (car ret)) 50 (phrase (car ret))
78 (address (car (cdr ret))) 51 (address (car (cdr ret)))
147 tm-bbdb/canonicalize-spaces)) 120 tm-bbdb/canonicalize-spaces))
148 121
149 122
150 ;;; @ BBDB functions for mime/viewer-mode 123 ;;; @ BBDB functions for mime/viewer-mode
151 ;;; 124 ;;;
125
126 (defvar tm-bbdb/auto-create-p nil)
152 127
153 (defun tm-bbdb/update-record (&optional offer-to-create) 128 (defun tm-bbdb/update-record (&optional offer-to-create)
154 "Return the record corresponding to the current MIME previewing message. 129 "Return the record corresponding to the current MIME previewing message.
155 Creating or modifying it as necessary. A record will be created if 130 Creating or modifying it as necessary. A record will be created if
156 tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and 131 tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
176 offer-to-create) 151 offer-to-create)
177 offer-to-create)) 152 offer-to-create))
178 )))) 153 ))))
179 154
180 (defun tm-bbdb/annotate-sender (string) 155 (defun tm-bbdb/annotate-sender (string)
181 "Add a line to the end of the Notes field of the BBDB record 156 "Add a line to the end of the Notes field of the BBDB record
182 corresponding to the sender of this message." 157 corresponding to the sender of this message."
183 (interactive 158 (interactive
184 (list (if bbdb-readonly-p 159 (list (if bbdb-readonly-p
185 (error "The Insidious Big Brother Database is read-only.") 160 (error "The Insidious Big Brother Database is read-only.")
186 (read-string "Comments: ")))) 161 (read-string "Comments: "))))
207 (error "unperson")))) 182 (error "unperson"))))
208 183
209 (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) 184 (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
210 "Make the *BBDB* buffer be displayed along with the MIME preview window(s), 185 "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
211 displaying the record corresponding to the sender of the current message." 186 displaying the record corresponding to the sender of the current message."
212 (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer))) 187 (bbdb-pop-up-bbdb-buffer
213 (or framepop 188 (function
214 (bbdb-pop-up-bbdb-buffer 189 (lambda (w)
215 (function 190 (let ((b (current-buffer)))
216 (lambda (w) 191 (set-buffer (window-buffer w))
217 (let ((b (current-buffer))) 192 (prog1 (eq major-mode 'mime/viewer-mode)
218 (set-buffer (window-buffer w)) 193 (set-buffer b))))))
219 (prog1 (eq major-mode 'mime/viewer-mode) 194 (let ((bbdb-gag-messages t)
220 (set-buffer b))))))) 195 (bbdb-use-pop-up nil)
221 (let ((bbdb-gag-messages t) 196 (bbdb-electric-p nil))
222 (bbdb-use-pop-up nil) 197 (let ((record (tm-bbdb/update-record offer-to-create))
223 (bbdb-electric-p nil)) 198 (bbdb-elided-display (bbdb-pop-up-elided-display))
224 (let ((record (tm-bbdb/update-record offer-to-create)) 199 (b (current-buffer)))
225 (bbdb-elided-display (bbdb-pop-up-elided-display)) 200 (bbdb-display-records (if record (list record) nil))
226 (b (current-buffer))) 201 (or record
227 (if framepop 202 (delete-windows-on (get-buffer "*BBDB*")))
228 (if record 203 (set-buffer b)
229 (bbdb-display-records (list record)) 204 record)))
230 (framepop-banish))
231 (bbdb-display-records (if record (list record) nil))
232 (if (and (null record)
233 tm-bbdb/delete-empty-window)
234 (delete-windows-on (get-buffer "*BBDB*"))))
235 (set-buffer b)
236 record))))
237 205
238 (defun tm-bbdb/define-keys () 206 (defun tm-bbdb/define-keys ()
239 (let ((mime/viewer-mode-map (current-local-map))) 207 (let ((mime/viewer-mode-map (current-local-map)))
240 (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes) 208 (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes)
241 (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender) 209 (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender)
255 )) 223 ))
256 224
257 (defun signature/set-bbdb-sigtype (sigtype addr) 225 (defun signature/set-bbdb-sigtype (sigtype addr)
258 "Add sigtype information to BBDB." 226 "Add sigtype information to BBDB."
259 (let* ((bbdb-notice-hook nil) 227 (let* ((bbdb-notice-hook nil)
260 (record (bbdb-annotate-message-sender 228 (record (bbdb-annotate-message-sender
261 addr t 229 addr t
262 (bbdb-invoke-hook-for-value 230 (bbdb-invoke-hook-for-value
263 bbdb/mail-auto-create-p) 231 bbdb/mail-auto-create-p)
264 t))) 232 t)))
265 (if record 233 (if record
266 (progn 234 (progn
267 (bbdb-record-putprop record 'sigtype sigtype) 235 (bbdb-record-putprop record 'sigtype sigtype)
271 (defun signature/get-sigtype-from-bbdb (&optional verbose) 239 (defun signature/get-sigtype-from-bbdb (&optional verbose)
272 (let* ((to (std11-field-body "To")) 240 (let* ((to (std11-field-body "To"))
273 (addr (and to 241 (addr (and to
274 (car (cdr (mail-extract-address-components to))))) 242 (car (cdr (mail-extract-address-components to)))))
275 (sigtype (signature/get-bbdb-sigtype addr)) 243 (sigtype (signature/get-bbdb-sigtype addr))
276 return 244 return
277 ) 245 )
278 (if addr 246 (if addr
279 (if verbose 247 (if verbose
280 (progn 248 (progn
281 (setq return (signature/get-sigtype-interactively sigtype)) 249 (setq return (signature/get-sigtype-interactively sigtype))