home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / bbdb / bbdb-lucid.el < prev    next >
Encoding:
Text File  |  1992-07-31  |  7.5 KB  |  241 lines
  1. ;;; -*- Mode:Emacs-Lisp -*-
  2.  
  3. ;;; This file is the part of the Insidious Big Brother Database (aka BBDB),
  4. ;;; copyright (c) 1992 Jamie Zawinski <jwz@lucid.com>.
  5. ;;; Mouse sensitivity and menus for Lucid GNU Emacs.
  6. ;;; last change 31-jul-92.
  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 1, 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. ;;; This code is kind of kludgey, mostly because it needs to parse the contents
  23. ;;; of the *BBDB* buffer, since BBDB doesn't save the buffer-positions of the
  24. ;;; various fields when it fills in that buffer (doing that would be slow and
  25. ;;; cons a lot, so it doesn't seem to be worth it.)
  26.  
  27. (or (string-match "Lucid" emacs-version)
  28.     (error "This file only works in Lucid GNU Emacs."))
  29.  
  30. (require 'bbdb)
  31.  
  32. (define-key bbdb-mode-map 'button3 'bbdb-menu)
  33.  
  34. (or (find-face 'bbdb-name)
  35.     (face-differs-from-default-p (make-face 'bbdb-name))
  36.     (set-face-underline-p 'bbdb-name t))
  37.  
  38. (or (find-face 'bbdb-company)
  39.     (face-differs-from-default-p (make-face 'bbdb-company))
  40.     (make-face-italic 'bbdb-company))
  41.  
  42. (or (find-face 'bbdb-field-value)
  43.     (make-face 'bbdb-field-value))
  44.  
  45. (or (find-face 'bbdb-field-name)
  46.     (face-differs-from-default-p (make-face 'bbdb-field-name))
  47.     (copy-face 'bold 'bbdb-field-name))
  48.  
  49. ;##autoload
  50. (defun bbdb-fontify-buffer ()
  51.   (save-excursion
  52.     (set-buffer bbdb-buffer-name)
  53.     ;; first delete existing extents
  54.     (map-extents (function (lambda (x y) (delete-extent x)))
  55.          (current-buffer) (point-min) (point-max) nil)
  56.     (let ((rest bbdb-records)
  57.       record start end elided-p p e)
  58.       (while rest
  59.     (setq record (car (car rest))
  60.           elided-p (eq (nth 1 (car rest)) t)
  61.           start (marker-position (nth 2 (car rest)))
  62.           end (1- (or (nth 2 (car (cdr rest))) (point-max))))
  63.     (set-extent-attribute (make-extent start end) 'highlight)
  64.     (goto-char start)
  65.     (if elided-p
  66.         (progn
  67.           (move-to-column 48)
  68.           (skip-chars-backward " \t"))
  69.       (end-of-line))
  70.     (setq p (point))
  71.     (goto-char start)
  72.     (if (search-forward " - " p t)
  73.         (progn
  74.           (setq e (make-extent (point) p))
  75.           (set-extent-face e 'bbdb-company)
  76.           (set-extent-attribute e 'highlight)
  77.           (forward-char -3))
  78.       (goto-char p))
  79.     (setq e (make-extent start (point)))
  80.     (set-extent-face e 'bbdb-name)
  81.     (set-extent-attribute e 'highlight)
  82.     (forward-line 1)
  83.     (while (< (point) end)
  84.       (skip-chars-forward " \t")
  85.       (setq p (point))
  86.       (and (looking-at "[^:\n]+:")
  87.            (set-extent-face (make-extent p (match-end 0))
  88.                 'bbdb-field-name))
  89.       (while (progn (forward-line 1)
  90.             (looking-at "^\\(\t\t \\|                 \\)")))
  91.       (setq e (make-extent p (1- (point))))
  92.       (set-extent-face e 'bbdb-field-value)
  93.       (set-extent-attribute e 'highlight))
  94.     (setq rest (cdr rest))))))
  95.  
  96. (defvar global-bbdb-menu-commands
  97.   '(["Save BBDB" bbdb-save-db t]
  98.     ["Elide All Records" bbdb-elide-record t]
  99.     ["Finger All Records" bbdb-finger-record t]
  100.     ["BBDB Manual" bbdb-info t]
  101.     ["BBDB Quit" bbdb-bury-buffer t]
  102.     ))
  103.  
  104. (defun build-bbdb-finger-menu (record)
  105.   (let ((addrs (bbdb-record-net record)))
  106.     (if (cdr addrs)
  107.     (cons "Finger..."
  108.           (nconc
  109.            (mapcar '(lambda (addr)
  110.               (vector addr (list 'bbdb-finger record addr)
  111.                   t))
  112.                addrs)
  113.            (list "----"
  114.              (vector "Finger all addresses"
  115.                  (list 'bbdb-finger record '(4)) t))))
  116.       (vector (concat "Finger " (car addrs))
  117.           (list 'bbdb-finger record (car addrs)) t))))
  118.  
  119. (defun build-bbdb-sendmail-menu (record)
  120.   (let ((addrs (bbdb-record-net record)))
  121.     (if (cdr addrs)
  122.     (cons "Send Mail..."
  123.           (mapcar '(lambda (addr)
  124.              (vector addr (list 'bbdb-send-mail-internal
  125.                         (bbdb-dwim-net-address record addr))
  126.                  t))
  127.               addrs))
  128.       (vector (concat "Send mail to " (car addrs))
  129.           (list 'bbdb-send-mail-internal
  130.             (bbdb-dwim-net-address record (car addrs)))
  131.           t))))
  132.       
  133.  
  134. (defun build-bbdb-field-menu (record field)
  135.   (let ((type (car field)))
  136.     (nconc
  137.      (list
  138.       (concat "Commands for "
  139.           (cond ((eq type 'property)
  140.              (concat "\""
  141.                  (symbol-name (if (consp (car (cdr field)))
  142.                           (car (car (cdr field)))
  143.                         (car (cdr field))))
  144.                  "\" field:"))
  145.             ((eq type 'name) "Name field:")
  146.             ((eq type 'company) "Company field:")
  147.             ((eq type 'net) "Network Addresses field:")
  148.             ((eq type 'aka) "Alternate Names field:")
  149.             (t
  150.              (concat "\"" (aref (nth 1 field) 0) "\" "
  151.                  (capitalize (symbol-name type)) " field:"))))
  152.       "-----"
  153.       ["Edit Field" bbdb-edit-current-field t]
  154.       )
  155.      (if (memq type '(name company))
  156.      nil
  157.        (list ["Delete Field" bbdb-delete-current-field-or-record t]))
  158.      (cond ((eq type 'phone)
  159.         (list (vector (concat "Dial " (bbdb-phone-string (car (cdr field))))
  160.               (list 'bbdb-dial field nil) t)))
  161.        )
  162.      )))
  163.  
  164.  
  165. (defun build-bbdb-insert-field-menu (record)
  166.   (cons "Insert New Field..."
  167.     (mapcar
  168.      '(lambda (field)
  169.         (let ((type (intern (car field))))
  170.           (vector (car field)
  171.               (list 'bbdb-insert-new-field type
  172.                 (list 'bbdb-prompt-for-new-field-value type))
  173.               (not
  174.                (or (and (eq type 'net) (bbdb-record-net record))
  175.                (and (eq type 'AKA) (bbdb-record-aka record))
  176.                (and (eq type 'notes) (bbdb-record-notes record))
  177.                (and (consp (bbdb-record-raw-notes record))
  178.                 (assq type (bbdb-record-raw-notes record))))))))
  179.      (append '(("phone") ("address") ("net") ("AKA") ("notes"))
  180.          (bbdb-propnames)))))
  181.  
  182.  
  183. (defun build-bbdb-menu (record field)
  184.   (append
  185.    '("bbdb-menu" "Global BBDB Commands" "-----")
  186.    global-bbdb-menu-commands
  187.    (if record
  188.        (list
  189.     "-----"
  190.     (concat "Commands for record \""
  191.         (bbdb-record-name record) "\":")
  192.     "-----"
  193.     (vector "Delete Record"
  194.         (list 'bbdb-delete-current-record record) t)
  195.     (if (nth 1 (assq record bbdb-records))
  196.         ["Unelide Record" bbdb-elide-record t]
  197.       ["Elide Record" bbdb-elide-record t])
  198.     ["Omit Record" bbdb-omit-record t]
  199.     ["Refile (Merge) Record" bbdb-refile-record t]
  200.     ))
  201.    (if record
  202.        (list (build-bbdb-finger-menu record)))
  203.    (if (bbdb-record-net record)
  204.        (list (build-bbdb-sendmail-menu record)))
  205.    (if record
  206.        (list (build-bbdb-insert-field-menu record)))
  207.    (if field
  208.        (cons "-----" (build-bbdb-field-menu record field)))
  209.    ))
  210.  
  211.  
  212. ;##autoload
  213. (defun bbdb-menu (e)
  214.   (interactive "e")
  215.   (mouse-set-point e)
  216.   (require 'bbdb-com)
  217.   (beginning-of-line)
  218.   (popup-menu
  219.    (save-window-excursion
  220.      (save-excursion
  221.        (mouse-set-point e)
  222.        (let ((extent (or (extent-at (point) (current-buffer) 'highlight)
  223.              (error "")))
  224.          record field face)
  225.      (highlight-extent extent t)    ; shouldn't be necessary...
  226.      (goto-char (extent-start-position extent))
  227.      (beginning-of-line)
  228.      (setq record (bbdb-current-record)
  229.            face (extent-face extent)
  230.            field (cond ((memq face
  231.                   '(bbdb-name bbdb-field-value bbdb-field-name))
  232.                 (bbdb-current-field))
  233.                ((eq face 'bbdb-company)
  234.                 (cons 'company (cdr (bbdb-current-field))))
  235.                (t nil)))
  236.      (build-bbdb-menu record field))))))
  237.  
  238. (bbdb-add-hook 'bbdb-list-hook 'bbdb-fontify-buffer)
  239.  
  240. (provide 'bbdb-lucid)
  241.