diff options
Diffstat (limited to 'lisp/bbdb-srv.el')
| -rw-r--r-- | lisp/bbdb-srv.el | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/lisp/bbdb-srv.el b/lisp/bbdb-srv.el new file mode 100644 index 0000000..d28235b --- /dev/null +++ b/lisp/bbdb-srv.el @@ -0,0 +1,285 @@ +;;; -*- Mode:Emacs-Lisp -*- + +;;; This file is the part of the Insidious Big Brother Database (aka BBDB), +;;; copyright (c) 1995 Jamie Zawinski <jwz@netscape.com>. +;;; Invoking BBDB from another process, via `gnudoit'. +;;; See the file bbdb.texinfo for documentation. +;;; +;;; 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 2, 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. + +;;; This requires the `gnuserv' and `itimer' packages. +;;; +;;; To use: +;;; +;;; First, do `(gnuserv-start)' to initialize the emacs server process. +;;; If you don't know what this does, see the doc for gnuserv.el. +;;; +;;; Then, an external process may invoke `gnudoit' in the following way: +;;; +;;; gnudoit '(bbdb-server "...all message headers..")' +;;; +;;; The bbdb-srv.perl program is a good choice for this; it takes a header +;;; block on stdin, and converts them to a lisp string, taking care to +;;; "sanitize" them so that hostile data can't take over the executing shell. +;;; +;;; The string should be a validly-formatted-and-quoted lisp string, and +;;; should contain multiple lines, which are the headers of the message for +;;; which a record should be displayed. It should contain at least a "From:" +;;; header, or nothing will be displayed, but it should contain as many headers +;;; as your various BBDB hooks might want access to. +;;; +;;; Records will not be displayed until no record has been requested for +;;; `bbdb/srv-display-delay' seconds (default 2.) This is to prevent rapid +;;; display of records from queueing up and swamping the emacs server process. +;;; +;;; Note that in order for this to build, itimer.el and gnuserv.el must be in +;;; the build-path. The easiest way to achieve this is to set OTHERDIR to point +;;; to the directory/ies they're in. + +;;; A trivial application of this is the shell command: +;;; +;;; echo 'From: Jamie Zawinski <jwz@netscape.com>' | bbdb-srv.perl +;;; +;;; which will cause the corresponding record to be displayed. +;;; A more interesting application of this is: +;;; +;;; setenv NS_MSG_DISPLAY_HOOK bbdb-srv.perl +;;; +;;; which will hook BBDB up to Mozilla (Unix Netscape Mail and Netscape News +;;; versions 3.0b2 and later only.) + +(require 'bbdb) +(require 'bbdb-com) +(require 'bbdb-hooks) + + +(eval-when-compile + (require 'mail-utils) ;; for mail-strip-quoted-names + (require 'bbdb-gui) ;; for extents macros + (if (featurep 'xemacs) + () + (fset 'set-keymap-name 'ignore) + (fset 'frame-lowest-window 'ignore))) + +;; newer version of gnuserv requires gnuserv-compat when using FSF emacs +;; but you might be using an older version, and we can't tell until you +;; crash it... +(or (fboundp 'define-obsolete-variable-alias) + (if (locate-library "gnuserv-compat") + (require 'gnuserv-compat))) +(require 'gnuserv) +(require 'itimer) + +(defcustom bbdb/srv-auto-create-p nil + "*Like `bbdb/news-auto-create-p' and `bbdb/mail-auto-create-p', +but for the case where the record is being displayed by some external +process via the `gnudoit' mechanism. + +If this is t, then records will automatically be created; if this is a +function name or lambda, then it is called with no arguments to decide +whether an entry should be automatically created. You can use this to, +for example, create or not create messages which have a particular subject. + +`bbdb/srv-auto-create-mail-news-dispatcher' is a good value for this -- +that function will try to decide if this is a mail message or a news +message, and then run either `bbdb/news-auto-create-p' or +`bbdb/mail-auto-create-p' as appropriate." + :group 'bbdb-utilities-server + :type '(choice (const :tag "Don't automatically create records" nil) + (const :tag "Automatically create records" t) + (sexp :tag "Use function to determine record creation" + bbdb/srv-auto-create-mail-news-dispatcher))) + +(defcustom bbdb/srv-display-delay 2 + "*How long (in seconds) we must be idle before displaying a record." + :group 'bbdb-utilities-server + :type 'integer) + +(defvar bbdb/srv-pending-headers nil) +(defvar bbdb/srv-pending-map + (and (fboundp 'bbdb-set-extent-property) + (condition-case nil + (let ((m (make-sparse-keymap))) + (set-keymap-name m 'bbdb/srv-pending-map) + (define-key m 'button1 'bbdb/srv-pending-add) + m) + (error nil)))) + +(defun bbdb/srv-handle-headers (headers &optional create-p) + "Display (or create) the BBDB entry corresponding to the message headers. +HEADERS should be a string containing an RFC822 header block; at least a +\"From:\" header should be provided, but others will be made available to +the various hooks (like `bbdb-notice-hook' and `bbdb/news-auto-create-p')." + (let ((buf "*bbdb-tmp*") + (record nil) + (bbdb-force-dialog-boxes t) ; affects bbdb-y-or-n-p + from) + (save-excursion + (set-buffer (or (get-buffer buf) + (progn + (setq buf (get-buffer-create buf)) + (set-buffer buf) + (buffer-disable-undo buf) + buf))) + (erase-buffer) + (insert headers "\n\n") + (setq from (mail-fetch-field "from")) + (if (or (null from) + (string-match (bbdb-user-mail-names) + (mail-strip-quoted-names from))) + ;; if logged-in user sent this, use recipients. + (setq from (or (mail-fetch-field "to") from))) + (if from + (setq record + (bbdb-annotate-message-sender from t + (or create-p + (bbdb-invoke-hook-for-value + bbdb/srv-auto-create-p)) + nil)))) + (let ((w (get-buffer-window bbdb-buffer-name))) + (if w + nil + (setq w (selected-window)) + (unwind-protect + (progn + (if (fboundp 'frame-lowest-window) + (select-window (frame-lowest-window))) + (bbdb-pop-up-bbdb-buffer)) + (select-window w)) + (setq w (get-buffer-window bbdb-buffer-name)) + (if (fboundp 'set-window-dedicated-p) + (set-window-dedicated-p w bbdb-buffer-name)))) + (cond (record + (let ((bbdb-gag-messages t) + (bbdb-use-pop-up nil) + (bbdb-electric-p nil) + (b (current-buffer))) + (save-window-excursion ;; needed to get around XEmacs 19.15 bug? + (bbdb-display-records (list record)) bbdb-pop-up-display-layout) + (set-buffer b))) + ((and from (not create-p) bbdb/srv-pending-map) + (setq bbdb/srv-pending-headers headers) + (save-excursion + (set-buffer bbdb-buffer-name) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert "\t\t\t") + (let ((p (point)) + e) + (insert from) + (setq e (bbdb-make-extent p (point))) + (bbdb-set-extent-face e 'bold) + (bbdb-set-extent-property e 'highlight t) + (bbdb-set-extent-property e 'keymap bbdb/srv-pending-map) + ) + (insert "\n\n\t\t\tClick to add to BBDB.") + )))))) + +(defun bbdb/srv-pending-add () + (interactive "@") + (or bbdb/srv-pending-headers (error "lost headers?")) + (bbdb/srv-handle-headers bbdb/srv-pending-headers t)) + + +(defvar bbdb/srv-itimer-arg nil) +(defun bbdb/srv-itimer () + "Used as a timer function by bbdb/srv-handle-headers-with-delay. +This invokes bbdb/srv-handle-headers with bbdb/srv-itimer-arg. +We do it this way instead of by using a lambda to start-itimer so that +we cons less." + (defvar current-itimer) + (if current-itimer (delete-itimer current-itimer)) + (if bbdb/srv-itimer-arg + (bbdb/srv-handle-headers + (prog1 bbdb/srv-itimer-arg + (setq bbdb/srv-itimer-arg nil))))) + +;;;###autoload +(defun bbdb/srv-handle-headers-with-delay (headers) + "Just like bbdb/srv-handle-headers, but only updates every few seconds. +This is so that trying to display many records in succession won't queue them +up, but will end up only displaying a record when no displays have been +requested for a couple of seconds." + (let* ((name "bbdb-srv") + (itimer (get-itimer name))) + (setq bbdb/srv-itimer-arg headers) + (if itimer + ;; It hasn't gone off yet; just change what it's argument will be. + nil + ;; else, start the timer going again. + (start-itimer name 'bbdb/srv-itimer bbdb/srv-display-delay nil)) + nil)) + +;;;###autoload +(defalias 'bbdb-srv 'bbdb/srv-handle-headers-with-delay) + +(autoload 'bbdb-header-start "bbdb-hooks") + +;;;###autoload +(defun bbdb/srv-auto-create-mail-news-dispatcher () + "For use as the value of bbdb/srv-auto-create-p. +This will try to decide if this is a mail message or a news message, and then +run either bbdb/news-auto-create-p or bbdb/mail-auto-create-p as appropriate. +\(The heuristic is that news messages never have a Status or X-Mozilla-Status +header; and that mail messages never have Path headers.)" + (let (mail-p) + (save-excursion + (let ((start (bbdb-header-start))) + (set-buffer (marker-buffer start)) + (setq mail-p + (cond ((progn (goto-char start) + (bbdb-extract-field-value "Status")) + t) + ((progn (goto-char start) + (bbdb-extract-field-value "X-Mozilla-Status")) + t) + ((progn (goto-char start) + (bbdb-extract-field-value "Path")) + nil) + (t t))))) ; can't tell -- guess mail. + (bbdb-invoke-hook-for-value + (if mail-p bbdb/mail-auto-create-p bbdb/news-auto-create-p)))) + + +;; For caller-id stuff +;;;###autoload +(defun bbdb-srv-add-phone (phone-string &optional description record) + (let ((phone (make-vector (if bbdb-north-american-phone-numbers-p + bbdb-phone-length + 2) + nil))) + (setq record (if (stringp record) + (or (bbdb-search-simple record "") + (bbdb-create-internal record nil nil nil nil nil)) + (bbdb-completing-read-record + (format "Add %s to: " phone-string)))) + (if (= 2 (length phone)) + (aset phone 1 phone-string) + (let ((newp (bbdb-parse-phone-number phone-string))) + (bbdb-phone-set-area phone (nth 0 newp)) + (bbdb-phone-set-exchange phone (nth 1 newp)) + (bbdb-phone-set-suffix phone (nth 2 newp)) + (bbdb-phone-set-extension phone (or (nth 3 newp) 0)))) + (bbdb-phone-set-location phone + (or description + (read-string "Phone number description: " + "cid"))) + (bbdb-record-set-phones record + (nconc (bbdb-record-phones record) (list phone))) + (bbdb-change-record record nil) + (bbdb-display-records (list record)) + record)) + +(provide 'bbdb-srv) |