Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-bbdb.el @ 74:54cc21c15cbb r20-0b32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b32
author cvs
date Mon, 13 Aug 2007 09:04:33 +0200
parents 131b0175ea99
children
comparison
equal deleted inserted replaced
73:e2d7a37b7c8d 74:54cc21c15cbb
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.1.1.1 1996/12/18 22:43:38 steve Exp $ 9 ;; Version: $Id: tm-bbdb.el,v 1.1.1.2 1996/12/21 20:50:46 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))
38 (require 'std11) 31 (require 'std11)
39 (require 'tm-ew-d) 32 (require 'tm-ew-d)
40 (require 'tm-view) 33 (require 'tm-view)
41 34 (if (module-installed-p 'bbdb-com)
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.")
42 71
43 ;;; @ mail-extr 72 ;;; @ mail-extr
44 ;;; 73 ;;;
45
46 (defvar tm-bbdb/use-mail-extr t)
47 74
48 (defun tm-bbdb/extract-address-components (str) 75 (defun tm-bbdb/extract-address-components (str)
49 (let* ((ret (std11-extract-address-components str)) 76 (let* ((ret (std11-extract-address-components str))
50 (phrase (car ret)) 77 (phrase (car ret))
51 (address (car (cdr ret))) 78 (address (car (cdr ret)))
120 tm-bbdb/canonicalize-spaces)) 147 tm-bbdb/canonicalize-spaces))
121 148
122 149
123 ;;; @ BBDB functions for mime/viewer-mode 150 ;;; @ BBDB functions for mime/viewer-mode
124 ;;; 151 ;;;
125
126 (defvar tm-bbdb/auto-create-p nil)
127 152
128 (defun tm-bbdb/update-record (&optional offer-to-create) 153 (defun tm-bbdb/update-record (&optional offer-to-create)
129 "Return the record corresponding to the current MIME previewing message. 154 "Return the record corresponding to the current MIME previewing message.
130 Creating or modifying it as necessary. A record will be created if 155 Creating or modifying it as necessary. A record will be created if
131 tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and 156 tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
151 offer-to-create) 176 offer-to-create)
152 offer-to-create)) 177 offer-to-create))
153 )))) 178 ))))
154 179
155 (defun tm-bbdb/annotate-sender (string) 180 (defun tm-bbdb/annotate-sender (string)
156 "Add a line to the end of the Notes field of the BBDB record 181 "Add a line to the end of the Notes field of the BBDB record
157 corresponding to the sender of this message." 182 corresponding to the sender of this message."
158 (interactive 183 (interactive
159 (list (if bbdb-readonly-p 184 (list (if bbdb-readonly-p
160 (error "The Insidious Big Brother Database is read-only.") 185 (error "The Insidious Big Brother Database is read-only.")
161 (read-string "Comments: ")))) 186 (read-string "Comments: "))))
182 (error "unperson")))) 207 (error "unperson"))))
183 208
184 (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create) 209 (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
185 "Make the *BBDB* buffer be displayed along with the MIME preview window(s), 210 "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
186 displaying the record corresponding to the sender of the current message." 211 displaying the record corresponding to the sender of the current message."
187 (bbdb-pop-up-bbdb-buffer 212 (let ((framepop (eq temp-buffer-show-function 'framepop-display-buffer)))
188 (function 213 (or framepop
189 (lambda (w) 214 (bbdb-pop-up-bbdb-buffer
190 (let ((b (current-buffer))) 215 (function
191 (set-buffer (window-buffer w)) 216 (lambda (w)
192 (prog1 (eq major-mode 'mime/viewer-mode) 217 (let ((b (current-buffer)))
193 (set-buffer b)))))) 218 (set-buffer (window-buffer w))
194 (let ((bbdb-gag-messages t) 219 (prog1 (eq major-mode 'mime/viewer-mode)
195 (bbdb-use-pop-up nil) 220 (set-buffer b)))))))
196 (bbdb-electric-p nil)) 221 (let ((bbdb-gag-messages t)
197 (let ((record (tm-bbdb/update-record offer-to-create)) 222 (bbdb-use-pop-up nil)
198 (bbdb-elided-display (bbdb-pop-up-elided-display)) 223 (bbdb-electric-p nil))
199 (b (current-buffer))) 224 (let ((record (tm-bbdb/update-record offer-to-create))
200 (bbdb-display-records (if record (list record) nil)) 225 (bbdb-elided-display (bbdb-pop-up-elided-display))
201 (or record 226 (b (current-buffer)))
202 (delete-windows-on (get-buffer "*BBDB*"))) 227 (if framepop
203 (set-buffer b) 228 (if record
204 record))) 229 (bbdb-display-records (list 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))))
205 237
206 (defun tm-bbdb/define-keys () 238 (defun tm-bbdb/define-keys ()
207 (let ((mime/viewer-mode-map (current-local-map))) 239 (let ((mime/viewer-mode-map (current-local-map)))
208 (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes) 240 (define-key mime/viewer-mode-map ";" 'tm-bbdb/edit-notes)
209 (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender) 241 (define-key mime/viewer-mode-map ":" 'tm-bbdb/show-sender)
223 )) 255 ))
224 256
225 (defun signature/set-bbdb-sigtype (sigtype addr) 257 (defun signature/set-bbdb-sigtype (sigtype addr)
226 "Add sigtype information to BBDB." 258 "Add sigtype information to BBDB."
227 (let* ((bbdb-notice-hook nil) 259 (let* ((bbdb-notice-hook nil)
228 (record (bbdb-annotate-message-sender 260 (record (bbdb-annotate-message-sender
229 addr t 261 addr t
230 (bbdb-invoke-hook-for-value 262 (bbdb-invoke-hook-for-value
231 bbdb/mail-auto-create-p) 263 bbdb/mail-auto-create-p)
232 t))) 264 t)))
233 (if record 265 (if record
234 (progn 266 (progn
235 (bbdb-record-putprop record 'sigtype sigtype) 267 (bbdb-record-putprop record 'sigtype sigtype)
239 (defun signature/get-sigtype-from-bbdb (&optional verbose) 271 (defun signature/get-sigtype-from-bbdb (&optional verbose)
240 (let* ((to (std11-field-body "To")) 272 (let* ((to (std11-field-body "To"))
241 (addr (and to 273 (addr (and to
242 (car (cdr (mail-extract-address-components to))))) 274 (car (cdr (mail-extract-address-components to)))))
243 (sigtype (signature/get-bbdb-sigtype addr)) 275 (sigtype (signature/get-bbdb-sigtype addr))
244 return 276 return
245 ) 277 )
246 (if addr 278 (if addr
247 (if verbose 279 (if verbose
248 (progn 280 (progn
249 (setq return (signature/get-sigtype-interactively sigtype)) 281 (setq return (signature/get-sigtype-interactively sigtype))