Commit 3d1f556b authored by waider's avatar waider

resync to master CVS sources (some more compatibility fixes)

parent 10241e6fb96d
......@@ -33,47 +33,51 @@
;; MIGRATE XXX
(eval-and-compile
(if (fboundp 'set-specifier)
(fset 'bbdb-set-specifier 'set-specifier)
(fset 'bbdb-set-specifier 'ignore))
(defalias 'bbdb-set-specifier 'set-specifier)
(defalias 'bbdb-set-specifier 'ignore))
(if (fboundp 'make-glyph)
(fset 'bbdb-make-glyph 'make-glyph)
(fset 'bbdb-make-glyph 'ignore))
(defalias 'bbdb-make-glyph 'make-glyph)
(defalias 'bbdb-make-glyph 'ignore))
(if (fboundp 'set-glyph-face)
(fset 'bbdb-set-glyph-face 'set-glyph-face)
(fset 'bbdb-set-glyph-face 'ignore))
(defalias 'bbdb-set-glyph-face 'set-glyph-face)
(defalias 'bbdb-set-glyph-face 'ignore))
(if (fboundp 'highlight-headers-x-face)
(fset 'bbdb-highlight-headers-x-face 'highlight-headers-x-face)
(fset 'bbdb-highlight-headers-x-face 'ignore))
(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)
(fset 'bbdb-highlight-headers-x-face-to-pixmap 'highlight-headers-x-face-to-pixmap)
(fset 'bbdb-highlight-headers-x-face-to-pixmap 'ignore)))
(defalias 'bbdb-highlight-headers-x-face-to-pixmap
'highlight-headers-x-face-to-pixmap)
(defalias 'bbdb-highlight-headers-x-face-to-pixmap 'ignore)))
(if (string-match "XEmacs\\|Lucid" emacs-version)
(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 0 ))))
(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 0))))
(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)
(fset 'bbdb-find-face 'find-face)
(defalias 'bbdb-find-face 'find-face)
(if (fboundp 'internal-find-face) ;; GRR.
(fset 'bbdb-find-face 'internal-find-face)
(fset 'bbdb-find-face 'ignore)))) ; noop - you probably don't HAVE faces.
;; 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 data
(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
......@@ -91,20 +95,26 @@
;;; change bbdb-foo-extents below to vm-foo-extents, etc.
(eval-and-compile
(if (fboundp 'make-extent)
(fset 'bbdb-make-extent 'make-extent)
(fset 'bbdb-make-extent 'make-overlay))
(defalias 'bbdb-make-extent 'make-extent)
(defalias 'bbdb-make-extent 'make-overlay))
(if (fboundp 'delete-extent)
(fset 'bbdb-delete-extent 'delete-extent)
(fset 'bbdb-delete-extent 'delete-overlay))
(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)
(fset 'bbdb-set-extent-property '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
......@@ -113,11 +123,11 @@
(overlay-put e p v)))
(if (fboundp 'extent-property)
(fset 'bbdb-extent-property 'extent-property)
(fset 'bbdb-extent-property 'overlay-get))
(defalias 'bbdb-extent-property 'extent-property)
(defalias 'bbdb-extent-property 'overlay-get))
(if (fboundp 'extent-at)
(fset 'bbdb-extent-at '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)
......@@ -132,111 +142,127 @@
retval)))
(if (fboundp 'highlight-extent)
(fset 'bbdb-highlight-extent 'highlight-extent)
(fset 'bbdb-highlight-extent 'ignore)) ; XXX noop
(defalias 'bbdb-highlight-extent 'highlight-extent)
(defalias 'bbdb-highlight-extent 'ignore)) ; XXX noop
(if (fboundp 'extent-start-position)
(fset 'bbdb-extent-start-position 'extent-start-position)
(fset 'bbdb-extent-start-position 'overlay-start))
(defalias 'bbdb-extent-start-position 'extent-start-position)
(defalias 'bbdb-extent-start-position 'overlay-start))
(if (fboundp 'extent-end-position)
(fset 'bbdb-extent-end-position 'extent-end-position)
(fset 'bbdb-extent-end-position 'overlay-end))
(defalias 'bbdb-extent-end-position 'extent-end-position)
(defalias 'bbdb-extent-end-position 'overlay-end))
(if (fboundp 'extent-face)
(fset 'bbdb-extent-face 'extent-face)
(defalias 'bbdb-extent-face 'extent-face)
(defun bbdb-extent-face (extent)
(overlay-get extent 'face)))
(if (fboundp 'set-extent-face)
(fset 'bbdb-set-extent-face '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)
(fset 'bbdb-set-extent-begin-glyph 'set-extent-begin-glyph)
(fset 'bbdb-set-extent-begin-glyph 'ignore)) ; XXX noop
(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)
(fset 'bbdb-set-extent-end-glyph 'set-extent-end-glyph)
(fset 'bbdb-set-extent-end-glyph 'ignore))) ; XXX noop
(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 ()
(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)))
;; first delete existing extents
(mapcar (function (lambda(o)
(if o ;; may start with nil
(if (eq (bbdb-extent-property o 'data) 'bbdb)
(bbdb-delete-extent o)))))
(bbdb-list-extents))
(let ((rest bbdb-records)
record face start end elided-p p e)
(let ((rest (or records bbdb-records))
record face
start end s e
multi-line-p
property
extent)
(while rest
(setq record (car (car rest))
elided-p (eq (nth 1 (car rest)) t)
face (and (not elided-p) (bbdb-record-getprop record 'face))
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))))
(bbdb-set-extent-property (setq e (bbdb-make-extent start end))
'highlight t)
(bbdb-set-extent-property e 'data 'bbdb)
(if (< start (point-min)) (setq start (point-min)))
(if (> end (point-max)) (setq end (point-max)))
(mapcar (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 e 'priority 3)
(setq p (+ start (length (bbdb-record-name record))))
(if (bbdb-record-company record)
(setq p (next-single-property-change (+ p 3) 'bbdb-field)))
(bbdb-set-extent-property extent 'priority 3)
(if face (bbdb-hack-x-face face extent))
(goto-char start)
(if (search-forward " - " p t)
(progn
(setq e (bbdb-make-extent (point) p))
(bbdb-set-extent-property e 'data 'bbdb)
(bbdb-set-extent-face e 'bbdb-company)
(bbdb-set-extent-property e 'highlight t)
(bbdb-set-extent-property e 'priority 2)
(forward-char -3))
(goto-char p))
(setq e (bbdb-make-extent start (point)))
(bbdb-set-extent-property e 'data 'bbdb)
(bbdb-set-extent-face e 'bbdb-name)
(bbdb-set-extent-property e 'priority 2)
(bbdb-set-extent-property e 'highlight t)
(if face (bbdb-hack-x-face face e))
(forward-line 1)
(while (< (point) end)
(skip-chars-forward " \t")
(setq p (point))
(and (looking-at "[^:\n]+:")
(progn
(setq e (bbdb-make-extent p (match-end 0)))
(bbdb-set-extent-face e 'bbdb-field-name)
(bbdb-set-extent-property e 'priority 2)
(bbdb-set-extent-property e 'data 'bbdb)))
(while (progn (forward-line 1)
(looking-at "^\\(\t\t \\| \\)")))
(setq e (bbdb-make-extent p (1- (point))))
(bbdb-set-extent-property e 'data 'bbdb)
(bbdb-set-extent-face e 'bbdb-field-value)
(bbdb-set-extent-property e 'priority 2)
(bbdb-set-extent-property e 'highlight t))
(setq rest (cdr rest))))))
(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 (boundp 'highlight-headers-hack-x-face-p)
(funcall (intern ;; compiler
(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
......@@ -247,7 +273,7 @@ as of GNU Emacs 20.7"
;; 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 data
(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
......@@ -295,8 +321,14 @@ as of GNU Emacs 20.7"
(bbdb-set-extent-property extent 'data 'bbdb))))))
(defvar bbdb-user-menu-commands nil
"User defined menu entries which should be appended to the BBDB menu." )
(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)))
......@@ -367,7 +399,9 @@ as of GNU Emacs 20.7"
'aka
(intern (car field)))))
(vector (car field)
(list 'bbdb-insert-new-field (list 'quote type)
(list 'bbdb-insert-new-field
record
(list 'quote type)
(list 'bbdb-prompt-for-new-field-value
(list 'quote type)))
(not
......@@ -416,12 +450,21 @@ as of GNU Emacs 20.7"
(list (build-bbdb-insert-field-menu record)))
(if field
(cons "-----" (build-bbdb-field-menu record field)))
bbdb-user-menu-commands)))
(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)
(fset 'bbdb-popup '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.
......@@ -463,15 +506,15 @@ as of GNU Emacs 20.7"
(funcall 'eval command)))))))))
;;;###autoload
(defun bbdb-menu (e)
(defun bbdb-menu (event)
(interactive "e")
(mouse-set-point 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 face)
record field)
(or (eq (bbdb-extent-property extent 'data) 'bbdb)
(error "not a bbdb extent"))
(bbdb-highlight-extent extent t)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment