summaryrefslogtreecommitdiff
path: root/lisp/bbdb-gui.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/bbdb-gui.el')
-rw-r--r--lisp/bbdb-gui.el530
1 files changed, 530 insertions, 0 deletions
diff --git a/lisp/bbdb-gui.el b/lisp/bbdb-gui.el
new file mode 100644
index 0000000..867bef5
--- /dev/null
+++ b/lisp/bbdb-gui.el
@@ -0,0 +1,530 @@
+;;; -*- Mode:Emacs-Lisp -*-
+;;; This file contains font and menu hacks for BBDB.
+
+;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
+;;; copyright (c) 1992, 1993, 1994 Jamie Zawinski <jwz@netscape.com>.
+
+;;; 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 code is kind of kludgey, mostly because it needs to parse the contents
+;;; of the *BBDB* buffer, since BBDB doesn't save the buffer-positions of the
+;;; various fields when it fills in that buffer (doing that would be slow and
+;;; cons a lot, so it doesn't seem to be worth it.)
+
+(require 'bbdb)
+(require 'bbdb-com)
+
+(eval-and-compile
+ (if (featurep 'xemacs)
+ (require 'overlay)))
+
+;; compiler whinage. Some of this is legacy stuff that would probably
+;; be better deleted.
+(defvar scrollbar-height nil)
+
+;; MIGRATE XXX
+(eval-and-compile
+ (if (fboundp 'set-specifier)
+ (defalias 'bbdb-set-specifier 'set-specifier)
+ (defalias 'bbdb-set-specifier 'ignore))
+ (if (fboundp 'make-glyph)
+ (defalias 'bbdb-make-glyph 'make-glyph)
+ (defalias 'bbdb-make-glyph 'ignore))
+ (if (fboundp 'set-glyph-face)
+ (defalias 'bbdb-set-glyph-face 'set-glyph-face)
+ (defalias 'bbdb-set-glyph-face 'ignore))
+ (if (fboundp 'highlight-headers-x-face)
+ (defalias 'bbdb-highlight-headers-x-face 'highlight-headers-x-face)
+ (defalias 'bbdb-highlight-headers-x-face 'ignore))
+ (if (fboundp 'highlight-headers-x-face-to-pixmap)
+ (defalias 'bbdb-highlight-headers-x-face-to-pixmap
+ 'highlight-headers-x-face-to-pixmap)
+ (defalias 'bbdb-highlight-headers-x-face-to-pixmap 'ignore)))
+
+
+(if (featurep 'xemacs)
+ (progn
+ (define-key bbdb-mode-map 'button3 'bbdb-menu)
+ (define-key bbdb-mode-map 'button2
+ (lambda (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (bbdb-toggle-records-display-layout nil))))
+ (define-key bbdb-mode-map [mouse-3] 'bbdb-menu)
+ (define-key bbdb-mode-map [mouse-2]
+ (lambda (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (bbdb-toggle-records-display-layout nil))))
+
+(eval-and-compile
+ (if (fboundp 'find-face)
+ (defalias 'bbdb-find-face 'find-face)
+ (if (fboundp 'internal-find-face) ;; GRR.
+ ;; This should be facep in Emacs 21
+ (defalias 'bbdb-find-face 'internal-find-face)
+ (defalias 'bbdb-find-face 'ignore)))) ; noop - you probably don't HAVE faces.
+
+(or (bbdb-find-face 'bbdb-name)
+ (face-differs-from-default-p (make-face 'bbdb-name))
+ (set-face-underline-p 'bbdb-name t))
+
+(condition-case nil
+ (or (bbdb-find-face 'bbdb-company)
+ (face-differs-from-default-p (make-face 'bbdb-company))
+ (make-face-italic 'bbdb-company)) ;; this can fail on emacs
+ (error nil))
+
+(or (bbdb-find-face 'bbdb-field-value)
+ (make-face 'bbdb-field-value))
+
+(or (bbdb-find-face 'bbdb-field-name)
+ (face-differs-from-default-p (make-face 'bbdb-field-name))
+ (copy-face 'bold 'bbdb-field-name))
+
+;;; Extents vs. Overlays unhappiness
+;;; FIXME: see if VM is around, and call its extents code instead;
+;;; change bbdb-foo-extents below to vm-foo-extents, etc.
+(eval-and-compile
+ (if (fboundp 'make-extent)
+ (defalias 'bbdb-make-extent 'make-extent)
+ (defalias 'bbdb-make-extent 'make-overlay))
+
+ (if (fboundp 'delete-extent)
+ (defalias 'bbdb-delete-extent 'delete-extent)
+ (defalias 'bbdb-delete-extent 'delete-overlay))
+
+ (if (fboundp 'mapcar-extents)
+ (defmacro bbdb-list-extents() `(mapcar-extents 'identity))
+ (defun bbdb-list-extents()
+ (let ((o (overlay-lists))) (nconc (car o) (cdr o)))))
+
+ (if (fboundp 'mapcar-extents)
+ (defmacro bbdb-extents-in (s e)
+ (list 'mapcar-extents ''identity nil nil s e))
+ (defmacro bbdb-extents-in (s e)
+ (list 'overlays-in s e)))
+
+ (if (fboundp 'set-extent-property)
+ (defalias 'bbdb-set-extent-property 'set-extent-property)
+ (defun bbdb-set-extent-property( e p v )
+ (if (eq 'highlight p)
+ (if v
+ (overlay-put e 'mouse-face 'highlight)
+ (overlay-put e 'mouse-face nil)))
+ (overlay-put e p v)))
+
+ (if (fboundp 'extent-property)
+ (defalias 'bbdb-extent-property 'extent-property)
+ (defalias 'bbdb-extent-property 'overlay-get))
+
+ (if (fboundp 'extent-at)
+ (defalias 'bbdb-extent-at 'extent-at)
+ (defun bbdb-extent-at (pos buf tag) "NOT FULL XEMACS IMPLEMENTATION"
+ (let ((o (overlays-at pos))
+ minpri retval)
+ (while (car o)
+ (let ((x (car o)))
+ (and (overlayp x)
+ (overlay-get x tag)
+ (if (or (null minpri) (> minpri (overlay-get x 'priority)))
+ (setq retval x
+ minpri (overlay-get x 'priority))))
+ (setq o (cdr o))))
+ retval)))
+
+ (if (fboundp 'highlight-extent)
+ (defalias 'bbdb-highlight-extent 'highlight-extent)
+ (defalias 'bbdb-highlight-extent 'ignore)) ; XXX noop
+
+ (if (fboundp 'extent-start-position)
+ (defalias 'bbdb-extent-start-position 'extent-start-position)
+ (defalias 'bbdb-extent-start-position 'overlay-start))
+
+ (if (fboundp 'extent-end-position)
+ (defalias 'bbdb-extent-end-position 'extent-end-position)
+ (defalias 'bbdb-extent-end-position 'overlay-end))
+
+ (if (fboundp 'extent-face)
+ (defalias 'bbdb-extent-face 'extent-face)
+ (defun bbdb-extent-face (extent)
+ (overlay-get extent 'face)))
+
+ (if (fboundp 'set-extent-face)
+ (defalias 'bbdb-set-extent-face 'set-extent-face)
+ (defun bbdb-set-extent-face (extent face) "set the face for an overlay"
+ (overlay-put extent 'face face)))
+
+ (if (fboundp 'set-extent-begin-glyph)
+ (defalias 'bbdb-set-extent-begin-glyph 'set-extent-begin-glyph)
+ (defalias 'bbdb-set-extent-begin-glyph 'ignore)) ; XXX noop
+
+ (if (fboundp 'set-extent-end-glyph)
+ (defalias 'bbdb-set-extent-end-glyph 'set-extent-end-glyph)
+ (defalias 'bbdb-set-extent-end-glyph 'ignore))) ; XXX noop
+
+
+(eval-when-compile (defvar scrollbar-height))
+;;;###autoload
+(defun bbdb-fontify-buffer (&optional records)
+ (interactive)
+ (save-excursion
+ (set-buffer bbdb-buffer-name)
+ (if (featurep 'scrollbar)
+ (bbdb-set-specifier scrollbar-height (cons (current-buffer) 0)))
+
+ (let ((rest (or records bbdb-records))
+ record face
+ start end s e
+ multi-line-p
+ property
+ extent)
+
+ (while rest
+ (setq record (car (car rest))
+ multi-line-p (string-match "multi-line"
+ (symbol-name (nth 1 (car rest))))
+ face (and multi-line-p (bbdb-record-getprop record 'face))
+ start (marker-position (nth 2 (car rest)))
+ end (1- (or (nth 2 (car (cdr rest))) (point-max))))
+
+ (if (< start (point-min)) (setq start (point-min)))
+ (if (> end (point-max)) (setq end (point-max)))
+
+ (mapc (function (lambda(o)
+ (if (and o
+ (eq (bbdb-extent-property o 'data)
+ 'bbdb))
+ (bbdb-delete-extent o))))
+ (bbdb-extents-in start end))
+
+ (setq extent (bbdb-make-extent start end))
+ (bbdb-set-extent-property extent 'highlight t)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ ;; note that on GNU Emacs, once you hit the main overlay, you
+ ;; have to move off the record and back on again before it'll
+ ;; notice that you're on a more specific overlay. This is
+ ;; bogus, like most GNU Emacs GUI stuff.
+ (bbdb-set-extent-property extent 'priority 3)
+ (if face (bbdb-hack-x-face face extent))
+ (goto-char start)
+ (setq s start)
+ (setq property (cadr (member 'bbdb-field (text-properties-at s))))
+ (while (and s (< s end))
+ (setq e (or (next-single-property-change (1+ s) 'bbdb-field)
+ (point-max)))
+ (cond ((equal property '(name))
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-name))
+ ((equal property '(company))
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-company))
+ ((member 'field-name property)
+ (goto-char s)
+ (setq extent (bbdb-make-extent s e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-field-name))
+ (t
+ (setq extent (bbdb-make-extent start e))
+ (bbdb-set-extent-property extent 'priority 2)
+ (bbdb-set-extent-property extent 'data 'bbdb)
+ (bbdb-set-extent-face extent 'bbdb-field-value)))
+ (setq s e)
+ (while (and s (null (setq property
+ (cadr (member 'bbdb-field
+ (text-properties-at s))))))
+ (setq s (next-single-property-change s 'bbdb-field))))
+
+ (setq rest (cdr rest))
+ (if (null (caar rest))
+ (setq rest nil))))))
+
+;;; share the xface cache data with VM if it's around
+(defvar vm-xface-cache (make-vector 29 0))
+(eval-when-compile (defvar highlight-headers-hack-x-face-p))
+
+;; In Emacs 21, this could use the x-face support from Gnus.
+(defun bbdb-hack-x-face (face extent)
+ "Process a face property of a record and honour it.
+Not done for GNU Emacs just yet, since it doesn't have image support
+as of GNU Emacs 20.7"
+ (if (not (or (and (fboundp 'highlight-headers-hack-x-face-p)
+ (symbol-value (intern ;; compiler
+ "highlight-headers-hack-x-face-p"))) ;; ick.
+ (and (featurep 'xemacs)
+ (string-match "^21\\." emacs-version)))) ;; XXX
+ () ;; nothing doing
+ (setq face (bbdb-split face "\n"))
+ (while face
+ (cond
+
+ ;; ripped pretty much verbatim from VM; X Faces for recent XEmacsen.
+ ((string-match "^21\\." emacs-version) ;; XXX how far back can I go?
+ (condition-case nil
+ (let* ((h (concat "X-Face: " (car face))) ;; from vm-display-xface
+ (g (intern h vm-xface-cache)))
+ (if (bbdb-find-face 'vm-xface) ;; use the same face as VM
+ nil
+ (make-face 'vm-xface)
+ (set-face-background 'vm-xface "white")
+ (set-face-foreground 'vm-xface "black"))
+ (if (boundp g)
+ (setq g (symbol-value g))
+ (set g (bbdb-make-glyph
+ (list
+ (vector 'xface ':data h)))) ;; XXX use API
+ (setq g (symbol-value g))
+ (bbdb-set-glyph-face g 'vm-xface))
+ (bbdb-set-extent-property extent 'vm-xface t)
+ (bbdb-set-extent-begin-glyph extent g))
+ (error nil))) ;; looks like you don't have xface support, d00d
+
+ ;; requires lemacs 19.10 version of highlight-headers.el
+ ((fboundp 'highlight-headers-x-face) ; the 19.10 way
+ (bbdb-highlight-headers-x-face (car face) extent)
+ (let ((b (bbdb-extent-property extent 'begin-glyph)))
+ (cond (b ; I'd like this to be an end-glyph instead
+ (bbdb-set-extent-property extent 'begin-glyph nil)
+ (bbdb-set-extent-property extent 'end-glyph b)))))
+
+ ((fboundp 'highlight-headers-x-face-to-pixmap) ; the 19.13 way
+ (save-excursion
+ (set-buffer (get-buffer-create " *tmp*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert (car face))
+ (bbdb-set-extent-begin-glyph extent nil)
+ (bbdb-set-extent-end-glyph extent
+ (bbdb-highlight-headers-x-face-to-pixmap
+ (point-min) (point-max)))
+ (erase-buffer))))
+
+ ;; more faces?
+ (setq face (cdr face))
+ (cond (face ; there are more, so clone the extent
+ (setq extent (bbdb-make-extent
+ (bbdb-extent-start-position extent)
+ (bbdb-extent-end-position extent)))
+ (bbdb-set-extent-property extent 'data 'bbdb))))))
+
+
+(defcustom bbdb-user-menu-commands nil
+ "User defined menu entries which should be appended to the BBDB menu.
+This should be a list of menu entries.
+When set to a fucntion the function gets called with two arguments the
+RECORD and the FIELD and it should either return nil or a list of menu
+entries."
+ :group 'bbdb-database
+ :type 'sexp)
+
+(defun build-bbdb-finger-menu (record)
+ (let ((addrs (bbdb-record-finger-host record)))
+ (if (cdr addrs)
+ (cons "Finger..."
+ (nconc
+ (mapcar (lambda (addr)
+ (vector addr (list 'bbdb-finger record addr)
+ t))
+ addrs)
+ (list "----"
+ (vector "Finger all addresses"
+ (list 'bbdb-finger record ''(4)) t))))
+ (vector (concat "Finger " (car addrs))
+ (list 'bbdb-finger record (car addrs)) t))))
+
+(defun build-bbdb-sendmail-menu (record)
+ (let ((addrs (bbdb-record-net record)))
+ (if (cdr addrs)
+ (cons "Send Mail..."
+ (mapcar (lambda (addr)
+ (vector addr (list 'bbdb-send-mail-internal
+ (bbdb-dwim-net-address record addr))
+ t))
+ addrs))
+ (vector (concat "Send mail to " (car addrs))
+ (list 'bbdb-send-mail-internal
+ (bbdb-dwim-net-address record (car addrs)))
+ t))))
+
+
+(defun build-bbdb-field-menu (record field)
+ (let ((type (car field)))
+ (nconc
+ (list
+ (concat "Commands for "
+ (cond ((eq type 'property)
+ (concat "\""
+ (symbol-name (if (consp (car (cdr field)))
+ (car (car (cdr field)))
+ (car (cdr field))))
+ "\" field:"))
+ ((eq type 'name) "Name field:")
+ ((eq type 'company) "Company field:")
+ ((eq type 'net) "Network Addresses field:")
+ ((eq type 'aka) "Alternate Names field:")
+ (t
+ (concat "\"" (aref (nth 1 field) 0) "\" "
+ (capitalize (symbol-name type)) " field:"))))
+ "-----"
+ ["Edit Field" bbdb-edit-current-field t]
+ )
+ (if (memq type '(name company))
+ nil
+ (list ["Delete Field" bbdb-delete-current-field-or-record t]))
+ (cond ((eq type 'phone)
+ (list (vector (concat "Dial " (bbdb-phone-string (car (cdr field))))
+ (list 'bbdb-dial (list 'quote field) nil) t)))
+ )
+ )))
+
+
+(defun build-bbdb-insert-field-menu (record)
+ (cons "Insert New Field..."
+ (mapcar
+ (lambda (field)
+ (let ((type (if (string= (car field) "AKA")
+ 'aka
+ (intern (car field)))))
+ (vector (car field)
+ (list 'bbdb-insert-new-field
+ record
+ (list 'quote type)
+ (list 'bbdb-prompt-for-new-field-value
+ (list 'quote type)))
+ (not
+ (or (and (eq type 'net) (bbdb-record-net record))
+ (and (eq type 'aka) (bbdb-record-aka record))
+ (and (eq type 'notes) (bbdb-record-notes record))
+ (and (consp (bbdb-record-raw-notes record))
+ (assq type (bbdb-record-raw-notes record))))))))
+ (append '(("phone") ("address") ("net") ("AKA") ("notes"))
+ (bbdb-propnames)))))
+
+
+(defun build-bbdb-menu (record field)
+ (delete
+ nil
+ (append
+ '("bbdb-menu" "Global BBDB Commands" "-----")
+ (list
+ ["Save BBDB" bbdb-save-db t]
+ ["Toggle All Records Display Layout"
+ bbdb-toggle-all-records-display-layout t]
+ ["Finger All Records" (bbdb-finger (mapcar 'car bbdb-records)) t]
+ ["BBDB Manual" bbdb-info t]
+ ["BBDB Quit" bbdb-bury-buffer t])
+ (if record
+ (list
+ "-----"
+ (concat "Commands for record \""
+ (bbdb-record-name record) "\":")
+ "-----"
+ (vector "Delete Record"
+ (list 'bbdb-delete-current-record record) t)
+ ["Toggle Records Display Layout" bbdb-toggle-records-display-layout t]
+ (if (and (not (eq 'full-multi-line
+ (nth 1 (assq record bbdb-records))))
+ (bbdb-display-layout-get-option 'multi-line 'omit))
+ ["Fully Display Record" bbdb-display-record-completely t])
+ ["Omit Record" bbdb-omit-record t]
+ ["Refile (Merge) Record" bbdb-refile-record t]
+ ))
+ (if record
+ (list (build-bbdb-finger-menu record)))
+ (if (bbdb-record-net record)
+ (list (build-bbdb-sendmail-menu record)))
+ (if record
+ (list (build-bbdb-insert-field-menu record)))
+ (if field
+ (cons "-----" (build-bbdb-field-menu record field)))
+ (if bbdb-user-menu-commands
+ (let ((menu (if (functionp bbdb-user-menu-commands)
+ (funcall bbdb-user-menu-commands record field)
+ bbdb-user-menu-commands)))
+ (if menu
+ (append ["-----"]
+ ["User Defined Commands"]
+ ["-----"]
+ menu)))))))
+
+(eval-and-compile
+ (if (fboundp 'popup-menu)
+ (progn
+ (fset 'bbdb-popup 'popup-menu)
+ (fset 'bbdb-desc-to-menu 'identity))
+ ;; This is really, REALLY ugly, but it saves me some coding and uses
+ ;; the correct keymap API instead of carnal knowledge of keymap
+ ;; structure.
+ (defun bbdb-desc-to-menu(desc)
+ (let ((map (make-sparse-keymap (car desc)))
+ (desc (reverse (cdr desc))) ;; throw away header, reorient list
+ (txtcount 0) elt elt-name)
+ (while (setq elt (car desc))
+ ;; fake a key binding name
+ (setq elt-name (intern (format "fake%d" txtcount))
+ txtcount (+ 1 txtcount))
+ (cond
+ ;; non-active entries in the menu
+ ((stringp elt)
+ (define-key map (vector elt-name) (list elt)))
+
+ ;; active entries in the menu
+ ((vectorp elt)
+ (define-key map (vector elt-name) (cons (aref elt 0) (aref elt 1))))
+
+ ;; submenus
+ ((listp elt)
+ (define-key map (vector elt-name)
+ (cons (car elt) (bbdb-desc-to-menu elt))))
+ )
+ (setq desc (cdr desc)))
+ map))
+ ;; this does the actual popping up & parsing nonsense
+ (defun bbdb-popup( desc &optional event )
+ (let ((map (bbdb-desc-to-menu desc)) result)
+ (setq result (x-popup-menu t map))
+ (if result
+ (let ((command (lookup-key map (vconcat result))))
+ ;; Clear out echoing, which perhaps shows a prefix arg.
+ (message "")
+ (if command
+ (if (commandp command)
+ (command-execute command)
+ (funcall 'eval command)))))))))
+
+;;;###autoload
+(defun bbdb-menu (event)
+ (interactive "e")
+ (mouse-set-point event)
+ (bbdb-popup
+ (save-window-excursion
+ (save-excursion
+ (let ((extent (or (bbdb-extent-at (point) (current-buffer) 'highlight)
+ (error "")))
+ record field)
+ (or (eq (bbdb-extent-property extent 'data) 'bbdb)
+ (error "not a bbdb extent"))
+ (bbdb-highlight-extent extent t)
+ (setq record (bbdb-current-record)
+ field (get-text-property (point) 'bbdb-field))
+ (build-bbdb-menu record field))))))
+
+;; tell everyone else we're here.
+(provide 'bbdb-gui)