cgit.sxemacs.org Git - packages/blob - xemacs-packages/bbdb/lisp/bbdb-srv.el

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2
   3 ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
   4 ;;; copyright (c) 1995 Jamie Zawinski <jwz@netscape.com>.
   5 ;;; Invoking BBDB from another process, via `gnudoit'.
   6 ;;; See the file bbdb.texinfo for documentation.
   7 ;;;
   8 ;;; The Insidious Big Brother Database is free software; you can redistribute
   9 ;;; it and/or modify it under the terms of the GNU General Public License as
  10 ;;; published by the Free Software Foundation; either version 2, or (at your
  11 ;;; option) any later version.
  12 ;;;
  13 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  14 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  15 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  16 ;;; details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  20 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 ;;
  23 ;; $Id: bbdb-srv.el,v 1.9 2007-02-23 20:24:08 fenk Exp $
  24
  25 ;;; This requires the `gnuserv' and `itimer' packages.
  26 ;;;
  27 ;;; To use:
  28 ;;;
  29 ;;; First, do `(gnuserv-start)' to initialize the emacs server process.
  30 ;;; If you don't know what this does, see the doc for gnuserv.el.
  31 ;;;
  32 ;;; Then, an external process may invoke `gnudoit' in the following way:
  33 ;;;
  34 ;;;     gnudoit '(bbdb-server "...all message headers..")'
  35 ;;;
  36 ;;; The bbdb-srv.perl program is a good choice for this; it takes a header
  37 ;;; block on stdin, and converts them to a lisp string, taking care to
  38 ;;; "sanitize" them so that hostile data can't take over the executing shell.
  39 ;;;
  40 ;;; The string should be a validly-formatted-and-quoted lisp string, and
  41 ;;; should contain multiple lines, which are the headers of the message for
  42 ;;; which a record should be displayed.  It should contain at least a "From:"
  43 ;;; header, or nothing will be displayed, but it should contain as many headers
  44 ;;; as your various BBDB hooks might want access to.
  45 ;;;
  46 ;;; Records will not be displayed until no record has been requested for
  47 ;;; `bbdb/srv-display-delay' seconds (default 2.)  This is to prevent rapid
  48 ;;; display of records from queueing up and swamping the emacs server process.
  49 ;;;
  50 ;;; Note that in order for this to build, itimer.el and gnuserv.el must be in
  51 ;;; the build-path. The easiest way to achieve this is to set OTHERDIR to point
  52 ;;; to the directory/ies they're in.
  53
  54 ;;; A trivial application of this is the shell command:
  55 ;;;
  56 ;;;    echo 'From: Jamie Zawinski <jwz@netscape.com>' | bbdb-srv.perl
  57 ;;;
  58 ;;; which will cause the corresponding record to be displayed.
  59 ;;; A more interesting application of this is:
  60 ;;;
  61 ;;;    setenv NS_MSG_DISPLAY_HOOK bbdb-srv.perl
  62 ;;;
  63 ;;; which will hook BBDB up to Mozilla (Unix Netscape Mail and Netscape News
  64 ;;; versions 3.0b2 and later only.)
  65
  66 (require 'bbdb)
  67 (require 'bbdb-com)
  68 (require 'bbdb-hooks)
  69
  70
  71 (eval-when-compile
  72   (require 'mail-utils) ;; for mail-strip-quoted-names
  73   (require 'bbdb-gui) ;; for extents macros
  74   (if (featurep 'xemacs)
  75       ()
  76     (fset 'set-keymap-name 'ignore)
  77     (fset 'frame-lowest-window 'ignore)))
  78
  79 ;; newer version of gnuserv requires gnuserv-compat when using FSF emacs
  80 ;; but you might be using an older version, and we can't tell until you
  81 ;; crash it...
  82 (or (fboundp 'define-obsolete-variable-alias)
  83     (if (locate-library "gnuserv-compat")
  84         (require 'gnuserv-compat)))
  85 (require 'gnuserv)
  86 (require 'itimer)
  87
  88 (defcustom bbdb/srv-auto-create-p nil
  89   "*Like `bbdb/news-auto-create-p' and `bbdb/mail-auto-create-p',
  90 but for the case where the record is being displayed by some external
  91 process via the `gnudoit' mechanism.
  92
  93 If this is t, then records will automatically be created; if this is a
  94 function name or lambda, then it is called with no arguments to decide
  95 whether an entry should be automatically created.  You can use this to,
  96 for example, create or not create messages which have a particular subject.
  97
  98 `bbdb/srv-auto-create-mail-news-dispatcher' is a good value for this --
  99 that function will try to decide if this is a mail message or a news
 100 message, and then run either `bbdb/news-auto-create-p' or
 101 `bbdb/mail-auto-create-p' as appropriate."
 102   :group 'bbdb-utilities-server
 103   :type '(choice (const :tag "Don't automatically create records" nil)
 104          (const :tag "Automatically create records" t)
 105          (sexp :tag "Use function to determine record creation"
 106                bbdb/srv-auto-create-mail-news-dispatcher)))
 107
 108 (defcustom bbdb/srv-display-delay 2
 109   "*How long (in seconds) we must be idle before displaying a record."
 110   :group 'bbdb-utilities-server
 111   :type 'integer)
 112
 113 (defvar bbdb/srv-pending-headers nil)
 114 (defvar bbdb/srv-pending-map
 115   (and (fboundp 'bbdb-set-extent-property)
 116        (condition-case nil
 117        (let ((m (make-sparse-keymap)))
 118          (set-keymap-name m 'bbdb/srv-pending-map)
 119          (define-key m 'button1 'bbdb/srv-pending-add)
 120          m)
 121      (error nil))))
 122
 123 (defun bbdb/srv-handle-headers (headers &optional create-p)
 124   "Display (or create) the BBDB entry corresponding to the message headers.
 125 HEADERS should be a string containing an RFC822 header block; at least a
 126 \"From:\" header should be provided, but others will be made available to
 127 the various hooks (like `bbdb-notice-hook' and `bbdb/news-auto-create-p')."
 128   (let ((buf "*bbdb-tmp*")
 129     (record nil)
 130     (bbdb-force-dialog-boxes t) ; affects bbdb-y-or-n-p
 131     from)
 132     (save-excursion
 133       (set-buffer (or (get-buffer buf)
 134               (progn
 135             (setq buf (get-buffer-create buf))
 136             (set-buffer buf)
 137             (buffer-disable-undo buf)
 138             buf)))
 139       (erase-buffer)
 140       (insert headers "\n\n")
 141       (setq from (mail-fetch-field "from"))
 142       (if (or (null from)
 143           (string-match (bbdb-user-mail-names)
 144                 (mail-strip-quoted-names from)))
 145       ;; if logged-in user sent this, use recipients.
 146       (setq from (or (mail-fetch-field "to") from)))
 147       (if from
 148       (setq record
 149         (bbdb-annotate-message-sender from t
 150                           (or create-p
 151                           (bbdb-invoke-hook-for-value
 152                            bbdb/srv-auto-create-p))
 153                           nil))))
 154     (let ((w (get-buffer-window bbdb-buffer-name)))
 155       (if w
 156       nil
 157     (setq w (selected-window))
 158     (unwind-protect
 159         (progn
 160           (if (fboundp 'frame-lowest-window)
 161               (select-window (frame-lowest-window)))
 162           (bbdb-pop-up-bbdb-buffer))
 163       (select-window w))
 164     (setq w (get-buffer-window bbdb-buffer-name))
 165     (if (fboundp 'set-window-dedicated-p)
 166         (set-window-dedicated-p w bbdb-buffer-name))))
 167     (cond (record
 168        (let ((bbdb-gag-messages t)
 169          (bbdb-use-pop-up nil)
 170          (bbdb-electric-p nil)
 171          (b (current-buffer)))
 172          (save-window-excursion ;; needed to get around XEmacs 19.15 bug?
 173            (bbdb-display-records (list record)) bbdb-pop-up-display-layout)
 174          (set-buffer b)))
 175       ((and from (not create-p) bbdb/srv-pending-map)
 176        (setq bbdb/srv-pending-headers headers)
 177        (save-excursion
 178          (set-buffer bbdb-buffer-name)
 179          (let ((buffer-read-only nil))
 180            (erase-buffer)
 181            (insert "\t\t\t")
 182            (let ((p (point))
 183              e)
 184          (insert from)
 185          (setq e (bbdb-make-extent p (point)))
 186          (bbdb-set-extent-face e 'bold)
 187          (bbdb-set-extent-property e 'highlight t)
 188          (bbdb-set-extent-property e 'keymap bbdb/srv-pending-map)
 189          )
 190            (insert "\n\n\t\t\tClick to add to BBDB.")
 191            ))))))
 192
 193 (defun bbdb/srv-pending-add ()
 194   (interactive "@")
 195   (or bbdb/srv-pending-headers (error "lost headers?"))
 196   (bbdb/srv-handle-headers bbdb/srv-pending-headers t))
 197
 198
 199 (defvar bbdb/srv-itimer-arg nil)
 200 (defun bbdb/srv-itimer ()
 201   "Used as a timer function by bbdb/srv-handle-headers-with-delay.
 202 This invokes bbdb/srv-handle-headers with bbdb/srv-itimer-arg.
 203 We do it this way instead of by using a lambda to start-itimer so that
 204 we cons less."
 205   (defvar current-itimer)
 206   (if current-itimer (delete-itimer current-itimer))
 207   (if bbdb/srv-itimer-arg
 208       (bbdb/srv-handle-headers
 209        (prog1 bbdb/srv-itimer-arg
 210      (setq bbdb/srv-itimer-arg nil)))))
 211
 212 ;;;###autoload
 213 (defun bbdb/srv-handle-headers-with-delay (headers)
 214   "Just like bbdb/srv-handle-headers, but only updates every few seconds.
 215 This is so that trying to display many records in succession won't queue them
 216 up, but will end up only displaying a record when no displays have been
 217 requested for a couple of seconds."
 218   (let* ((name "bbdb-srv")
 219      (itimer (get-itimer name)))
 220     (setq bbdb/srv-itimer-arg headers)
 221     (if itimer
 222     ;; It hasn't gone off yet; just change what it's argument will be.
 223     nil
 224       ;; else, start the timer going again.
 225       (start-itimer name 'bbdb/srv-itimer bbdb/srv-display-delay nil))
 226     nil))
 227
 228 ;;;###autoload
 229 (defalias 'bbdb-srv 'bbdb/srv-handle-headers-with-delay)
 230
 231 (autoload 'bbdb-header-start "bbdb-hooks")
 232
 233 ;;;###autoload
 234 (defun bbdb/srv-auto-create-mail-news-dispatcher ()
 235   "For use as the value of bbdb/srv-auto-create-p.
 236 This will try to decide if this is a mail message or a news message, and then
 237 run either bbdb/news-auto-create-p or bbdb/mail-auto-create-p as appropriate.
 238 \(The heuristic is that news messages never have a Status or X-Mozilla-Status
 239 header; and that mail messages never have Path headers.)"
 240   (let (mail-p)
 241     (save-excursion
 242       (let ((start (bbdb-header-start)))
 243     (set-buffer (marker-buffer start))
 244     (setq mail-p
 245           (cond ((progn (goto-char start)
 246                 (bbdb-extract-field-value "Status"))
 247              t)
 248             ((progn (goto-char start)
 249                 (bbdb-extract-field-value "X-Mozilla-Status"))
 250              t)
 251             ((progn (goto-char start)
 252                 (bbdb-extract-field-value "Path"))
 253              nil)
 254             (t t)))))       ; can't tell -- guess mail.
 255     (bbdb-invoke-hook-for-value
 256      (if mail-p bbdb/mail-auto-create-p bbdb/news-auto-create-p))))
 257
 258 \f
 259 ;; For caller-id stuff
 260 ;;;###autoload
 261 (defun bbdb-srv-add-phone (phone-string &optional description record)
 262   (let ((phone (make-vector (if bbdb-north-american-phone-numbers-p
 263                                 bbdb-phone-length
 264                               2)
 265                             nil)))
 266     (setq record (if (stringp record)
 267                      (or (bbdb-search-simple record "")
 268                          (bbdb-create-internal record nil nil nil nil nil))
 269                    (bbdb-completing-read-record
 270                     (format "Add %s to: " phone-string))))
 271     (if (= 2 (length phone))
 272         (aset phone 1 phone-string)
 273       (let ((newp (bbdb-parse-phone-number phone-string)))
 274         (bbdb-phone-set-area phone (nth 0 newp))
 275         (bbdb-phone-set-exchange phone (nth 1 newp))
 276         (bbdb-phone-set-suffix phone (nth 2 newp))
 277         (bbdb-phone-set-extension phone (or (nth 3 newp) 0))))
 278     (bbdb-phone-set-location phone
 279                              (or description
 280                                  (read-string "Phone number description: "
 281                                               "cid")))
 282     (bbdb-record-set-phones record
 283                             (nconc (bbdb-record-phones record) (list phone)))
 284     (bbdb-change-record record nil)
 285     (bbdb-display-records (list record))
 286     record))
 287
 288 (provide 'bbdb-srv)