tm-bbdb.el

   1 ;;;
   2 ;;; tm-bbdb.el --- tm shred module for BBDB
   3 ;;;
   4 ;;; Copyright (C) 1995 KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>
   5 ;;;
   6 ;;; Author: KOBAYASHI Shuhei <shuhei@cmpt01.phys.tohoku.ac.jp>
   7 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version: $Id: tm-bbdb.el,v 2.0 1996/01/23 04:34:12 morioka Exp $
   9 ;;; Keywords: mail, news, MIME, multimedia, multilingual, BBDB
  10 ;;;
  11 ;;; This file is part of tm (Tools for MIME).
  12 ;;;
  13 ;;; This program is free software; you can redistribute it and/or
  14 ;;; modify it under the terms of the GNU General Public License as
  15 ;;; published by the Free Software Foundation; either version 2, or
  16 ;;; (at your option) any later version.
  17 ;;;
  18 ;;; This program is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;;; General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with This program.  If not, write to the Free Software
  25 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26 ;;;
  27 ;;; Code:
  28
  29 (require 'bbdb)
  30 (require 'tl-822)
  31 (require 'tm-ew-d)
  32
  33 (defun tm-bbdb/extract-address-components (str)
  34   (let* ((ret     (rfc822/extract-address-components str))
  35          (phrase  (car ret))
  36          (address (cdr ret))
  37          (methods tm-bbdb/canonicalize-full-name-methods))
  38     (while (and phrase methods)
  39       (setq phrase  (funcall (car methods) phrase)
  40             methods (cdr methods)))
  41     (cons phrase address)
  42     ))
  43
  44 (fset 'mail-extract-address-components
  45       (symbol-function 'tm-bbdb/extract-address-components))
  46 (provide 'mail-extr)
  47
  48 (or (fboundp 'tm:bbdb-extract-field-value)
  49     (progn
  50       ;; (require 'bbdb-hooks) ; not provided.
  51       (or (fboundp 'bbdb-extract-field-value)
  52           (load "bbdb-hooks"))
  53       (fset 'tm:bbdb-extract-field-value
  54             (symbol-function 'bbdb-extract-field-value))
  55       (defun bbdb-extract-field-value (field)
  56         (let ((value (rfc822/get-field-body field)))
  57           (and value
  58                (mime-eword/decode-string value))))
  59       ))
  60
  61
  62 ;;; @ full-name canonicalization methods
  63 ;;;
  64
  65 (defun tm-bbdb/canonicalize-spaces (str)
  66   (let (dest)
  67     (while (string-match "\\s +" str)
  68       (setq dest (cons (substring str 0 (match-beginning 0)) dest))
  69       (setq str (substring str (match-end 0)))
  70       )
  71     (or (string= str "")
  72         (setq dest (cons str dest)))
  73     (setq dest (nreverse dest))
  74     (mapconcat 'identity dest " ")
  75     ))
  76
  77 (defun tm-bbdb/canonicalize-dots (str)
  78   (let (dest)
  79     (while (string-match "\\." str)
  80       (setq dest (cons (substring str 0 (match-end 0)) dest))
  81       (setq str (substring str (match-end 0)))
  82       )
  83     (or (string= str "")
  84         (setq dest (cons str dest)))
  85     (setq dest (nreverse dest))
  86     (mapconcat 'identity dest " ")
  87     ))
  88
  89 (defvar tm-bbdb/canonicalize-full-name-methods nil)
  90
  91 (setq tm-bbdb/canonicalize-full-name-methods
  92       '(mime-eword/decode-string
  93         tm-bbdb/canonicalize-dots
  94         tm-bbdb/canonicalize-spaces))
  95
  96
  97 ;;; @ BBDB functions for mime/viewer-mode
  98 ;;;
  99
 100 (defvar tm-bbdb/auto-create-p nil)
 101
 102 (defun tm-bbdb/update-record (&optional offer-to-create)
 103   "Return the record corresponding to the current MIME previewing message.
 104 Creating or modifying it as necessary. A record will be created if
 105 tm-bbdb/auto-create-p is non-nil, or if OFFER-TO-CREATE is non-nil and
 106 the user confirms the creation."
 107   (save-excursion
 108     (and mime::article/preview-buffer
 109          (get-buffer mime::article/preview-buffer)
 110          (set-buffer mime::article/preview-buffer))
 111     (if bbdb-use-pop-up
 112         (tm-bbdb/pop-up-bbdb-buffer offer-to-create)
 113     (let ((from (rfc822/get-field-body "From")))
 114       (if (or (null from)
 115               (string-match (bbdb-user-mail-names)
 116                             (car
 117                              (cdr
 118                               ;; (tm-bbdb/extract-address-components from)
 119                               (mail-extract-address-components from)
 120                               ))))
 121           (setq from (or (rfc822/get-field-body "To")
 122                          from)))
 123       (if from
 124           (bbdb-annotate-message-sender
 125            from t
 126            (or (bbdb-invoke-hook-for-value tm-bbdb/auto-create-p)
 127                offer-to-create)
 128            offer-to-create))
 129       ))))
 130
 131 (defun tm-bbdb/annotate-sender (string)
 132   "Add a line to the end of the Notes field of the BBDB record
 133 corresponding to the sender of this message."
 134   (interactive
 135    (list (if bbdb-readonly-p
 136              (error "The Insidious Big Brother Database is read-only.")
 137            (read-string "Comments: "))))
 138   (bbdb-annotate-notes (tm-bbdb/update-record t) string))
 139
 140 (defun tm-bbdb/edit-notes (&optional arg)
 141   "Edit the notes field or (with a prefix arg) a user-defined field
 142 of the BBDB record corresponding to the sender of this message."
 143   (interactive "P")
 144   (let ((record (or (tm-bbdb/update-record t)
 145                     (error ""))))
 146     (bbdb-display-records (list record))
 147     (if arg
 148         (bbdb-record-edit-property record nil t)
 149       (bbdb-record-edit-notes record t))))
 150
 151 (defun tm-bbdb/show-sender ()
 152   "Display the contents of the BBDB for the sender of this message.
 153 This buffer will be in bbdb-mode, with associated keybindings."
 154   (interactive)
 155   (let ((record (tm-bbdb/update-record t)))
 156     (if record
 157         (bbdb-display-records (list record))
 158         (error "unperson"))))
 159
 160 (defun tm-bbdb/pop-up-bbdb-buffer (&optional offer-to-create)
 161   "Make the *BBDB* buffer be displayed along with the MIME preview window(s),
 162 displaying the record corresponding to the sender of the current message."
 163   (bbdb-pop-up-bbdb-buffer
 164     (function (lambda (w)
 165       (let ((b (current-buffer)))
 166         (set-buffer (window-buffer w))
 167         (prog1 (eq major-mode 'mime/viewer-mode)
 168           (set-buffer b))))))
 169   (let ((bbdb-gag-messages t)
 170         (bbdb-use-pop-up nil)
 171         (bbdb-electric-p nil))
 172     (let ((record (tm-bbdb/update-record offer-to-create))
 173           (bbdb-elided-display (bbdb-pop-up-elided-display))
 174           (b (current-buffer)))
 175       (bbdb-display-records (if record (list record) nil))
 176       (set-buffer b)
 177       record)))
 178
 179
 180 ;;; @ end
 181 ;;;
 182
 183 (provide 'tm-bbdb)
 184
 185 (run-hooks 'tm-bbdb-load-hook)
 186
 187 ;;; end of tm-bbdb.el