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

   1 ;;; -*- Mode:Emacs-Lisp -*-
   2 ;;; This file contains font and menu hacks for BBDB.
   3
   4 ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
   5 ;;; copyright (c) 1992, 1993, 1994 Jamie Zawinski <jwz@netscape.com>.
   6
   7 ;;; The Insidious Big Brother Database is free software; you can redistribute
   8 ;;; it and/or modify it under the terms of the GNU General Public License as
   9 ;;; published by the Free Software Foundation; either version 2, or (at your
  10 ;;; option) any later version.
  11 ;;;
  12 ;;; BBDB is distributed in the hope that it will be useful, but WITHOUT ANY
  13 ;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14 ;;; FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15 ;;; details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 ;;; This code is kind of kludgey, mostly because it needs to parse the contents
  22 ;;; of the *BBDB* buffer, since BBDB doesn't save the buffer-positions of the
  23 ;;; various fields when it fills in that buffer (doing that would be slow and
  24 ;;; cons a lot, so it doesn't seem to be worth it.)
  25
  26 (require 'bbdb)
  27 (require 'bbdb-com)
  28
  29 ;; compiler whinage. Some of this is legacy stuff that would probably
  30 ;; be better deleted.
  31 (defvar scrollbar-height nil)
  32
  33 ;; MIGRATE XXX
  34 (eval-and-compile
  35   (if (fboundp 'set-specifier)
  36       (defalias 'bbdb-set-specifier 'set-specifier)
  37     (defalias 'bbdb-set-specifier 'ignore))
  38   (if (fboundp 'make-glyph)
  39       (defalias 'bbdb-make-glyph 'make-glyph)
  40     (defalias 'bbdb-make-glyph 'ignore))
  41   (if (fboundp 'set-glyph-face)
  42       (defalias 'bbdb-set-glyph-face 'set-glyph-face)
  43     (defalias 'bbdb-set-glyph-face 'ignore))
  44   (if (fboundp 'highlight-headers-x-face)
  45       (defalias 'bbdb-highlight-headers-x-face 'highlight-headers-x-face)
  46     (defalias 'bbdb-highlight-headers-x-face 'ignore))
  47   (if (fboundp 'highlight-headers-x-face-to-pixmap)
  48       (defalias 'bbdb-highlight-headers-x-face-to-pixmap
  49             'highlight-headers-x-face-to-pixmap)
  50     (defalias 'bbdb-highlight-headers-x-face-to-pixmap 'ignore)))
  51
  52
  53 (if (featurep 'xemacs)
  54     (progn
  55       (define-key bbdb-mode-map 'button3 'bbdb-menu)
  56       (define-key bbdb-mode-map 'button2
  57         (lambda (e)
  58           (interactive "e")
  59           (mouse-set-point e)
  60           (bbdb-toggle-records-display-layout nil))))
  61   (define-key bbdb-mode-map [mouse-3] 'bbdb-menu)
  62   (define-key bbdb-mode-map [mouse-2]
  63     (lambda (e)
  64       (interactive "e")
  65       (mouse-set-point e)
  66       (bbdb-toggle-records-display-layout nil))))
  67
  68 (eval-and-compile
  69   (if (fboundp 'find-face)
  70       (defalias 'bbdb-find-face 'find-face)
  71     (if (fboundp 'internal-find-face) ;; GRR.
  72     ;; This should be facep in Emacs 21
  73         (defalias 'bbdb-find-face 'internal-find-face)
  74       (defalias 'bbdb-find-face 'ignore)))) ; noop - you probably don't HAVE faces.
  75
  76 (or (bbdb-find-face 'bbdb-name)
  77     (face-differs-from-default-p (make-face 'bbdb-name))
  78     (set-face-underline-p 'bbdb-name t))
  79
  80 (condition-case nil
  81     (or (bbdb-find-face 'bbdb-company)
  82         (face-differs-from-default-p (make-face 'bbdb-company))
  83         (make-face-italic 'bbdb-company)) ;; this can fail on emacs
  84   (error nil))
  85
  86 (or (bbdb-find-face 'bbdb-field-value)
  87     (make-face 'bbdb-field-value))
  88
  89 (or (bbdb-find-face 'bbdb-field-name)
  90     (face-differs-from-default-p (make-face 'bbdb-field-name))
  91     (copy-face 'bold 'bbdb-field-name))
  92
  93 ;;; Extents vs. Overlays unhappiness
  94 ;;; FIXME: see if VM is around, and call its extents code instead;
  95 ;;; change bbdb-foo-extents below to vm-foo-extents, etc.
  96 (eval-and-compile
  97   (if (fboundp 'make-extent)
  98       (defalias 'bbdb-make-extent 'make-extent)
  99     (defalias 'bbdb-make-extent 'make-overlay))
 100
 101   (if (fboundp 'delete-extent)
 102       (defalias 'bbdb-delete-extent 'delete-extent)
 103     (defalias 'bbdb-delete-extent 'delete-overlay))
 104
 105   (if (fboundp 'mapcar-extents)
 106       (defmacro bbdb-list-extents() `(mapcar-extents 'identity))
 107     (defun bbdb-list-extents()
 108       (let ((o (overlay-lists))) (nconc (car o) (cdr o)))))
 109
 110   (if (fboundp 'mapcar-extents)
 111       (defmacro bbdb-extents-in (s e)
 112         (list 'mapcar-extents ''identity nil nil s e))
 113     (defmacro bbdb-extents-in (s e)
 114       (list 'overlays-in s e)))
 115
 116   (if (fboundp 'set-extent-property)
 117       (defalias 'bbdb-set-extent-property 'set-extent-property)
 118     (defun bbdb-set-extent-property( e p v )
 119       (if (eq 'highlight p)
 120           (if v
 121               (overlay-put e 'mouse-face 'highlight)
 122             (overlay-put e 'mouse-face nil)))
 123       (overlay-put e p v)))
 124
 125   (if (fboundp 'extent-property)
 126       (defalias 'bbdb-extent-property 'extent-property)
 127     (defalias 'bbdb-extent-property 'overlay-get))
 128
 129   (if (fboundp 'extent-at)
 130       (defalias 'bbdb-extent-at 'extent-at)
 131     (defun bbdb-extent-at (pos buf tag) "NOT FULL XEMACS IMPLEMENTATION"
 132       (let ((o (overlays-at pos))
 133             minpri retval)
 134         (while (car o)
 135           (let ((x (car o)))
 136             (and (overlayp x)
 137                  (overlay-get x tag)
 138                  (if (or (null minpri) (> minpri (overlay-get x 'priority)))
 139                      (setq retval x
 140                            minpri (overlay-get x 'priority))))
 141             (setq o (cdr o))))
 142         retval)))
 143
 144   (if (fboundp 'highlight-extent)
 145       (defalias 'bbdb-highlight-extent 'highlight-extent)
 146     (defalias 'bbdb-highlight-extent 'ignore)) ; XXX noop
 147
 148   (if (fboundp 'extent-start-position)
 149       (defalias 'bbdb-extent-start-position 'extent-start-position)
 150     (defalias 'bbdb-extent-start-position 'overlay-start))
 151
 152   (if (fboundp 'extent-end-position)
 153       (defalias 'bbdb-extent-end-position 'extent-end-position)
 154     (defalias 'bbdb-extent-end-position 'overlay-end))
 155
 156   (if (fboundp 'extent-face)
 157       (defalias 'bbdb-extent-face 'extent-face)
 158     (defun bbdb-extent-face (extent)
 159       (overlay-get extent 'face)))
 160
 161   (if (fboundp 'set-extent-face)
 162       (defalias 'bbdb-set-extent-face 'set-extent-face)
 163     (defun bbdb-set-extent-face (extent face) "set the face for an overlay"
 164       (overlay-put extent 'face face)))
 165
 166   (if (fboundp 'set-extent-begin-glyph)
 167       (defalias 'bbdb-set-extent-begin-glyph 'set-extent-begin-glyph)
 168     (defalias 'bbdb-set-extent-begin-glyph 'ignore)) ; XXX noop
 169
 170   (if (fboundp 'set-extent-end-glyph)
 171       (defalias 'bbdb-set-extent-end-glyph 'set-extent-end-glyph)
 172     (defalias 'bbdb-set-extent-end-glyph 'ignore))) ; XXX noop
 173 \f
 174
 175 (eval-when-compile (defvar scrollbar-height))
 176 ;;;###autoload
 177 (defun bbdb-fontify-buffer (&optional records)
 178   (interactive)
 179   (save-excursion
 180     (set-buffer bbdb-buffer-name)
 181     (if (featurep 'scrollbar)
 182         (bbdb-set-specifier scrollbar-height (cons (current-buffer) 0)))
 183
 184     (let ((rest (or records bbdb-records))
 185           record face
 186           start end  s e
 187           multi-line-p
 188           property
 189           extent)
 190
 191       (while rest
 192         (setq record (car (car rest))
 193               multi-line-p (string-match "multi-line"
 194                                         (symbol-name (nth 1 (car rest))))
 195               face (and multi-line-p (bbdb-record-getprop record 'face))
 196               start (marker-position (nth 2 (car rest)))
 197               end (1- (or (nth 2 (car (cdr rest))) (point-max))))
 198
 199         (if (< start (point-min)) (setq start (point-min)))
 200         (if (> end (point-max)) (setq end (point-max)))
 201
 202         (mapcar (function (lambda(o)
 203                             (if (and o
 204                                      (eq (bbdb-extent-property o 'data)
 205                                          'bbdb))
 206                                 (bbdb-delete-extent o))))
 207                 (bbdb-extents-in start end))
 208
 209         (setq extent (bbdb-make-extent start end))
 210         (bbdb-set-extent-property extent 'highlight t)
 211         (bbdb-set-extent-property extent 'data 'bbdb)
 212         ;; note that on GNU Emacs, once you hit the main overlay, you
 213         ;; have to move off the record and back on again before it'll
 214         ;; notice that you're on a more specific overlay. This is
 215         ;; bogus, like most GNU Emacs GUI stuff.
 216         (bbdb-set-extent-property extent 'priority 3)
 217         (if face (bbdb-hack-x-face face extent))
 218         (goto-char start)
 219         (setq s start)
 220         (setq property (cadr (member 'bbdb-field (text-properties-at s))))
 221         (while (and s (< s end))
 222           (setq e (or (next-single-property-change (1+ s) 'bbdb-field)
 223                       (point-max)))
 224           (cond ((equal property '(name))
 225                  (setq extent (bbdb-make-extent s e))
 226                  (bbdb-set-extent-property extent 'priority 2)
 227                  (bbdb-set-extent-property extent 'data 'bbdb)
 228                  (bbdb-set-extent-face extent 'bbdb-name))
 229                 ((equal property '(company))
 230                  (setq extent (bbdb-make-extent s e))
 231                  (bbdb-set-extent-property extent 'priority 2)
 232                  (bbdb-set-extent-property extent 'data 'bbdb)
 233                  (bbdb-set-extent-face extent 'bbdb-company))
 234                 ((member 'field-name property)
 235                  (goto-char s)
 236                  (setq extent (bbdb-make-extent s e))
 237                  (bbdb-set-extent-property extent 'priority 2)
 238                  (bbdb-set-extent-property extent 'data 'bbdb)
 239                  (bbdb-set-extent-face extent 'bbdb-field-name))
 240                 (t
 241                  (setq extent (bbdb-make-extent start e))
 242                  (bbdb-set-extent-property extent 'priority 2)
 243                  (bbdb-set-extent-property extent 'data 'bbdb)
 244                  (bbdb-set-extent-face extent 'bbdb-field-value)))
 245           (setq s e)
 246           (while (and s (null (setq property
 247                                     (cadr (member 'bbdb-field
 248                                                   (text-properties-at s))))))
 249             (setq s (next-single-property-change s 'bbdb-field))))
 250
 251         (setq rest (cdr rest))
 252         (if (null (caar rest))
 253             (setq rest nil))))))
 254
 255 ;;; share the xface cache data with VM if it's around
 256 (defvar vm-xface-cache (make-vector 29 0))
 257 (eval-when-compile (defvar highlight-headers-hack-x-face-p))
 258
 259 ;; In Emacs 21, this could use the x-face support from Gnus.
 260 (defun bbdb-hack-x-face (face extent)
 261   "Process a face property of a record and honour it.
 262 Not done for GNU Emacs just yet, since it doesn't have image support
 263 as of GNU Emacs 20.7"
 264   (if (not (or (and (fboundp 'highlight-headers-hack-x-face-p)
 265                     (symbol-value (intern                          ;; compiler
 266                               "highlight-headers-hack-x-face-p"))) ;; ick.
 267                (and (featurep 'xemacs)
 268                     (string-match "^21\\." emacs-version)))) ;; XXX
 269       () ;; nothing doing
 270     (setq face (bbdb-split face "\n"))
 271     (while face
 272       (cond
 273
 274        ;; ripped pretty much verbatim from VM; X Faces for recent XEmacsen.
 275        ((string-match "^21\\." emacs-version) ;; XXX how far back can I go?
 276         (condition-case nil
 277             (let* ((h (concat "X-Face: " (car face))) ;; from vm-display-xface
 278                    (g (intern h vm-xface-cache)))
 279               (if (bbdb-find-face 'vm-xface) ;; use the same face as VM
 280                   nil
 281                 (make-face 'vm-xface)
 282                 (set-face-background 'vm-xface "white")
 283                 (set-face-foreground 'vm-xface "black"))
 284               (if (boundp g)
 285                   (setq g (symbol-value g))
 286                 (set g (bbdb-make-glyph
 287                         (list
 288                          (vector 'xface ':data h)))) ;; XXX use API
 289                 (setq g (symbol-value g))
 290                 (bbdb-set-glyph-face g 'vm-xface))
 291               (bbdb-set-extent-property extent 'vm-xface t)
 292               (bbdb-set-extent-begin-glyph extent g))
 293           (error nil))) ;; looks like you don't have xface support, d00d
 294
 295        ;; requires lemacs 19.10 version of highlight-headers.el
 296        ((fboundp 'highlight-headers-x-face)                     ; the 19.10 way
 297         (bbdb-highlight-headers-x-face (car face) extent)
 298         (let ((b (bbdb-extent-property extent 'begin-glyph)))
 299           (cond (b ; I'd like this to be an end-glyph instead
 300                  (bbdb-set-extent-property extent 'begin-glyph nil)
 301                  (bbdb-set-extent-property extent 'end-glyph b)))))
 302
 303        ((fboundp 'highlight-headers-x-face-to-pixmap)           ; the 19.13 way
 304         (save-excursion
 305           (set-buffer (get-buffer-create " *tmp*"))
 306           (buffer-disable-undo (current-buffer))
 307           (erase-buffer)
 308           (insert (car face))
 309           (bbdb-set-extent-begin-glyph extent nil)
 310           (bbdb-set-extent-end-glyph extent
 311                                 (bbdb-highlight-headers-x-face-to-pixmap
 312                                  (point-min) (point-max)))
 313           (erase-buffer))))
 314
 315       ;; more faces?
 316       (setq face (cdr face))
 317       (cond (face ; there are more, so clone the extent
 318              (setq extent (bbdb-make-extent
 319                            (bbdb-extent-start-position extent)
 320                            (bbdb-extent-end-position extent)))
 321              (bbdb-set-extent-property extent 'data 'bbdb))))))
 322
 323
 324 (defcustom bbdb-user-menu-commands nil
 325   "User defined menu entries which should be appended to the BBDB menu.
 326 This should be a list of menu entries.
 327 When set to a fucntion the function gets called with two arguments the
 328 RECORD and the FIELD and it should either return nil or a list of menu
 329 entries."
 330   :group 'bbdb-database
 331   :type 'sexp)
 332
 333 (defun build-bbdb-finger-menu (record)
 334   (let ((addrs (bbdb-record-finger-host record)))
 335     (if (cdr addrs)
 336         (cons "Finger..."
 337               (nconc
 338                (mapcar (lambda (addr)
 339                          (vector addr (list 'bbdb-finger record addr)
 340                                  t))
 341                        addrs)
 342                (list "----"
 343                      (vector "Finger all addresses"
 344                              (list 'bbdb-finger record ''(4)) t))))
 345       (vector (concat "Finger " (car addrs))
 346               (list 'bbdb-finger record (car addrs)) t))))
 347
 348 (defun build-bbdb-sendmail-menu (record)
 349   (let ((addrs (bbdb-record-net record)))
 350     (if (cdr addrs)
 351         (cons "Send Mail..."
 352               (mapcar (lambda (addr)
 353                         (vector addr (list 'bbdb-send-mail-internal
 354                                            (bbdb-dwim-net-address record addr))
 355                                 t))
 356                       addrs))
 357       (vector (concat "Send mail to " (car addrs))
 358               (list 'bbdb-send-mail-internal
 359                     (bbdb-dwim-net-address record (car addrs)))
 360               t))))
 361
 362
 363 (defun build-bbdb-field-menu (record field)
 364   (let ((type (car field)))
 365     (nconc
 366      (list
 367       (concat "Commands for "
 368               (cond ((eq type 'property)
 369                      (concat "\""
 370                              (symbol-name (if (consp (car (cdr field)))
 371                                               (car (car (cdr field)))
 372                                             (car (cdr field))))
 373                              "\" field:"))
 374                     ((eq type 'name) "Name field:")
 375                     ((eq type 'company) "Company field:")
 376                     ((eq type 'net) "Network Addresses field:")
 377                     ((eq type 'aka) "Alternate Names field:")
 378                     (t
 379                      (concat "\"" (aref (nth 1 field) 0) "\" "
 380                              (capitalize (symbol-name type)) " field:"))))
 381       "-----"
 382       ["Edit Field" bbdb-edit-current-field t]
 383       )
 384      (if (memq type '(name company))
 385          nil
 386        (list ["Delete Field" bbdb-delete-current-field-or-record t]))
 387      (cond ((eq type 'phone)
 388             (list (vector (concat "Dial " (bbdb-phone-string (car (cdr field))))
 389                           (list 'bbdb-dial (list 'quote field) nil) t)))
 390            )
 391      )))
 392
 393
 394 (defun build-bbdb-insert-field-menu (record)
 395   (cons "Insert New Field..."
 396         (mapcar
 397          (lambda (field)
 398            (let ((type (if (string= (car field) "AKA")
 399                            'aka
 400                          (intern (car field)))))
 401              (vector (car field)
 402                      (list 'bbdb-insert-new-field
 403                            record
 404                            (list 'quote type)
 405                            (list 'bbdb-prompt-for-new-field-value
 406                                  (list 'quote type)))
 407                      (not
 408                       (or (and (eq type 'net) (bbdb-record-net record))
 409                           (and (eq type 'aka) (bbdb-record-aka record))
 410                           (and (eq type 'notes) (bbdb-record-notes record))
 411                           (and (consp (bbdb-record-raw-notes record))
 412                                (assq type (bbdb-record-raw-notes record))))))))
 413          (append '(("phone") ("address") ("net") ("AKA") ("notes"))
 414                  (bbdb-propnames)))))
 415
 416
 417 (defun build-bbdb-menu (record field)
 418   (delete
 419    nil
 420    (append
 421     '("bbdb-menu" "Global BBDB Commands" "-----")
 422     (list
 423      ["Save BBDB" bbdb-save-db t]
 424      ["Toggle All Records Display Layout"
 425       bbdb-toggle-all-records-display-layout t]
 426     ["Finger All Records" (bbdb-finger (mapcar 'car bbdb-records)) t]
 427     ["BBDB Manual" bbdb-info t]
 428     ["BBDB Quit" bbdb-bury-buffer t])
 429     (if record
 430         (list
 431          "-----"
 432          (concat "Commands for record \""
 433                  (bbdb-record-name record) "\":")
 434          "-----"
 435          (vector "Delete Record"
 436                  (list 'bbdb-delete-current-record record) t)
 437          ["Toggle Records Display Layout" bbdb-toggle-records-display-layout t]
 438          (if (and (not (eq 'full-multi-line
 439                            (nth 1 (assq record bbdb-records))))
 440                   (bbdb-display-layout-get-option 'multi-line 'omit))
 441              ["Fully Display Record" bbdb-display-record-completely t])
 442          ["Omit Record" bbdb-omit-record t]
 443          ["Refile (Merge) Record" bbdb-refile-record t]
 444          ))
 445     (if record
 446         (list (build-bbdb-finger-menu record)))
 447     (if (bbdb-record-net record)
 448         (list (build-bbdb-sendmail-menu record)))
 449     (if record
 450         (list (build-bbdb-insert-field-menu record)))
 451     (if field
 452         (cons "-----" (build-bbdb-field-menu record field)))
 453     (if bbdb-user-menu-commands
 454         (let ((menu (if (functionp bbdb-user-menu-commands)
 455                         (funcall bbdb-user-menu-commands record field)
 456                       bbdb-user-menu-commands)))
 457           (if menu
 458               (append ["-----"]
 459                       ["User Defined Commands"]
 460                       ["-----"]
 461                       menu)))))))
 462
 463 (eval-and-compile
 464   (if (fboundp 'popup-menu)
 465       (progn
 466         (fset 'bbdb-popup 'popup-menu)
 467         (fset 'bbdb-desc-to-menu 'identity))
 468     ;; This is really, REALLY ugly, but it saves me some coding and uses
 469     ;; the correct keymap API instead of carnal knowledge of keymap
 470     ;; structure.
 471     (defun bbdb-desc-to-menu(desc)
 472       (let ((map (make-sparse-keymap (car desc)))
 473             (desc (reverse (cdr desc))) ;; throw away header, reorient list
 474             (txtcount 0) elt elt-name)
 475         (while (setq elt (car desc))
 476           ;; fake a key binding name
 477           (setq elt-name (intern (format "fake%d" txtcount))
 478                 txtcount (+ 1 txtcount))
 479           (cond
 480            ;; non-active entries in the menu
 481            ((stringp elt)
 482             (define-key map (vector elt-name) (list elt)))
 483
 484            ;; active entries in the menu
 485            ((vectorp elt)
 486             (define-key map (vector elt-name) (cons (aref elt 0) (aref elt 1))))
 487
 488            ;; submenus
 489            ((listp elt)
 490             (define-key map (vector elt-name)
 491               (cons (car elt) (bbdb-desc-to-menu elt))))
 492            )
 493           (setq desc (cdr desc)))
 494         map))
 495     ;; this does the actual popping up & parsing nonsense
 496     (defun bbdb-popup( desc &optional event )
 497       (let ((map (bbdb-desc-to-menu desc)) result)
 498         (setq result (x-popup-menu t map))
 499         (if result
 500             (let ((command (lookup-key map (vconcat result))))
 501               ;; Clear out echoing, which perhaps shows a prefix arg.
 502               (message "")
 503               (if command
 504                   (if (commandp command)
 505                       (command-execute command)
 506                     (funcall 'eval command)))))))))
 507
 508 ;;;###autoload
 509 (defun bbdb-menu (event)
 510   (interactive "e")
 511   (mouse-set-point event)
 512   (bbdb-popup
 513    (save-window-excursion
 514      (save-excursion
 515        (let ((extent (or (bbdb-extent-at (point) (current-buffer) 'highlight)
 516                          (error "")))
 517              record field)
 518          (or (eq (bbdb-extent-property extent 'data) 'bbdb)
 519              (error "not a bbdb extent"))
 520          (bbdb-highlight-extent extent t)
 521          (setq record (bbdb-current-record)
 522                field  (get-text-property (point) 'bbdb-field))
 523          (build-bbdb-menu record field))))))
 524
 525 ;; tell everyone else we're here.
 526 (provide 'bbdb-gui)