Commits

Anonymous committed 633f866

resync to master CVS sources (some more compatibility fixes)

Comments (0)

Files changed (1)

 ;; 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
 ;;; 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
       (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)
         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
 
        ;; 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
              (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)))
                            '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
         (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.
                     (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)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.