X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/c7bce5f21f8802b9c3be7691b6505162c230c232..e6608c123379bd53bf05d5982dc92a7e1769cad7:/lisp/facemenu.el

diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index e6b73b52d1..ca81ebec67 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -238,8 +238,8 @@ when they are created."
 (let ((map facemenu-menu))
   (define-key map [dc] (cons (purecopy "Display Colors") 'list-colors-display))
   (define-key map [df] (cons (purecopy "Display Faces") 'list-faces-display))
-  (define-key map [dp] (cons (purecopy "Describe Text")
-			     'describe-text-at))
+  (define-key map [dp] (cons (purecopy "Describe Properties")
+			     'describe-text-properties))
   (define-key map [ra] (cons (purecopy "Remove Text Properties")
 			     'facemenu-remove-all))
   (define-key map [rm] (cons (purecopy "Remove Face Properties")
@@ -362,7 +362,7 @@ typing a character to insert cancels the specification."
 			 (region-end))))
   (unless (color-defined-p color)
     (message "Color `%s' undefined" color))
-  (facemenu-add-new-face color 'facemenu-foreground-menu)
+  (facemenu-add-new-color color 'facemenu-foreground-menu)
   (facemenu-add-face (list (list :foreground color)) start end))
 
 ;;;###autoload
@@ -386,7 +386,7 @@ typing a character to insert cancels the specification."
 			 (region-end))))
   (unless (color-defined-p color)
     (message "Color `%s' undefined" color))
-  (facemenu-add-new-face color 'facemenu-background-menu)
+  (facemenu-add-new-color color 'facemenu-background-menu)
   (facemenu-add-face (list (list :background color)) start end))
 
 ;;;###autoload
@@ -460,202 +460,7 @@ These special properties include `invisible', `intangible' and `read-only'."
   (let ((inhibit-read-only t))
     (remove-text-properties 
      start end '(invisible nil intangible nil read-only nil))))
-
-;;; Describe-Text Mode.
-
-(defun describe-text-done ()
-  "Delete the current window or bury the current buffer."
-  (interactive)
-  (if (> (count-windows) 1)
-      (delete-window)
-    (bury-buffer)))
-
-(defvar describe-text-mode-map 
-  (let ((map (make-sparse-keymap)))
-    (set-keymap-parent map widget-keymap)
-    map)
-  "Keymap for `describe-text-mode'.")
-  
-(defcustom describe-text-mode-hook nil
-  "List of hook functions ran by `describe-text-mode'."
-  :type 'hook)
-
-(defun describe-text-mode ()
-  "Major mode for buffers created by `describe-text-at'.
-
-\\{describe-text-mode-map}
-Entry to this mode calls the value of `describe-text-mode-hook'
-if that value is non-nil."
-  (kill-all-local-variables)
-  (setq major-mode 'describe-text-mode
-	mode-name "Describe-Text")
-  (use-local-map describe-text-mode-map)
-  (widget-setup)
-  (run-hooks 'describe-text-mode-hook))
-
-;;; Describe-Text Utilities.
-
-(defun describe-text-widget (widget)
-  "Insert text to describe WIDGET in the current buffer."
-  (widget-create 'link
-		 :notify `(lambda (&rest ignore)
-			    (widget-browse ',widget))
-		 (format "%S" (if (symbolp widget) 
-				  widget
-				(car widget))))
-  (widget-insert " ")
-  (widget-create 'info-link :tag "widget" "(widget)Top"))
-
-(defun describe-text-sexp (sexp)
-  "Insert a short description of SEXP in the current buffer."
-  (let ((pp (condition-case signal
-		(pp-to-string sexp)
-	      (error (prin1-to-string signal)))))
-    (when (string-match "\n\\'" pp)
-      (setq pp (substring pp 0 (1- (length pp)))))
-    (if (cond ((string-match "\n" pp)
-	       nil)
-	      ((> (length pp) (- (window-width) (current-column)))
-	       nil)
-	      (t t))
-	(widget-insert pp)
-      (widget-create 'push-button
-		     :tag "show"
-		     :action (lambda (widget &optional event)
-			       (with-output-to-temp-buffer
-				   "*Pp Eval Output*"
-				 (princ (widget-get widget :value))))
-		     pp))))
-  
-
-(defun describe-text-properties (properties)
-  "Insert a description of PROPERTIES in the current buffer.
-PROPERTIES should be a list of overlay or text properties.
-The `category' property is made into a widget button that call 
-`describe-text-category' when pushed."
-  (while properties
-    (widget-insert (format "  %-20s " (car properties)))
-    (let ((key (nth 0 properties))
-	  (value (nth 1 properties)))
-      (cond ((eq key 'category)
-	     (widget-create 'link 
-			    :notify `(lambda (&rest ignore)
-				       (describe-text-category ',value))
-			    (format "%S" value)))
-	    ((widgetp value)
-	     (describe-text-widget value))
-	    (t
-	     (describe-text-sexp value))))
-    (widget-insert "\n")
-    (setq properties (cdr (cdr properties)))))
-
-;;; Describe-Text Commands.
-
-(defun describe-text-category (category)
-  "Describe a text property category."
-  (interactive "S")
-  (when (get-buffer "*Text Category*")
-    (kill-buffer "*Text Category*"))
-  (save-excursion
-    (with-output-to-temp-buffer "*Text Category*"
-      (set-buffer "*Text Category*")
-      (widget-insert "Category " (format "%S" category) ":\n\n")
-      (describe-text-properties (symbol-plist category))
-      (describe-text-mode)
-      (goto-char (point-min)))))
-
-;;;###autoload
-(defun describe-text-at (pos)
-  "Describe widgets, buttons, overlays and text properties at POS."
-  (interactive "d")
-  (when (eq (current-buffer) (get-buffer "*Text Description*"))
-    (error "Can't do self inspection"))
-  (let* ((properties (text-properties-at pos))
-	 (overlays (overlays-at pos))
-	 overlay
-	 (wid-field (get-char-property pos 'field))
-	 (wid-button (get-char-property pos 'button))
-	 (wid-doc (get-char-property pos 'widget-doc))
-	 ;; If button.el is not loaded, we have no buttons in the text.
-	 (button (and (fboundp 'button-at) (button-at pos)))
-	 (button-type (and button (button-type button)))
-	 (button-label (and button (button-label button)))
-	 (widget (or wid-field wid-button wid-doc)))
-    (if (not (or properties overlays))
-	(message "This is plain text.")
-      (when (get-buffer "*Text Description*")
-	(kill-buffer "*Text Description*"))
-      (save-excursion
-	(with-output-to-temp-buffer "*Text Description*"
-	  (set-buffer "*Text Description*")
-	  (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
-	  ;; Widgets
-	  (when (widgetp widget)
-	    (widget-insert (cond (wid-field "This is an editable text area")
-				 (wid-button "This is an active area")
-				 (wid-doc "This is documentation text")))
-	    (widget-insert " of a ")
-	    (describe-text-widget widget)
-	    (widget-insert ".\n\n"))
-	  ;; Buttons
-	  (when (and button (not (widgetp wid-button)))
-	    (widget-insert "Here is a " (format "%S" button-type) 
-			   " button labeled `" button-label "'.\n\n"))
-	  ;; Overlays
-	  (when overlays
-	    (if (eq (length overlays) 1)
-		(widget-insert "There is an overlay here:\n")
-	      (widget-insert "There are " (format "%d" (length overlays))
-			     " overlays here:\n"))
-	    (dolist (overlay overlays)
-	      (widget-insert " From " (format "%d" (overlay-start overlay)) 
-			     " to " (format "%d" (overlay-end overlay)) "\n")
-	      (describe-text-properties (overlay-properties overlay)))
-	    (widget-insert "\n"))
-	  ;; Text properties
-	  (when properties
-	    (widget-insert "There are text properties here:\n")
-	    (describe-text-properties properties))
-	  (describe-text-mode)
-	  (goto-char (point-min)))))))
-
-;;; List Text Properties
-
-;;;###autoload
-(defun list-text-properties-at (p)
-  "Pop up a buffer listing text-properties at LOCATION."
-  (interactive "d")
-  (let ((props (text-properties-at p))
-	category
-	str)
-    (if (null props)
-	(message "None")
-      (if (and (not (cdr (cdr props)))
-	       (not (eq (car props) 'category))
-	       (< (length (setq str (format "Text property at %d:  %s  %S"
-					    p (car props) (car (cdr props)))))
-		  (frame-width)))
-	  (message "%s" str)
-	(with-output-to-temp-buffer "*Text Properties*"
-	  (princ (format "Text properties at %d:\n\n" p))
-	  (setq help-xref-stack nil)
-	  (while props
-	    (if (eq (car props) 'category)
-		(setq category (car (cdr props))))
-	    (princ (format "%-20s %S\n"
-			   (car props) (car (cdr props))))
-	    (setq props (cdr (cdr props))))
-	  (if category
-	      (progn
-		(setq props (symbol-plist category))
-		(princ (format "\nCategory %s:\n\n" category))
-		(while props
-		  (princ (format "%-20s %S\n"
-				 (car props) (car (cdr props))))
-		  (if (eq (car props) 'category)
-		      (setq category (car (cdr props))))
-		  (setq props (cdr (cdr props)))))))))))
-
+
 ;;;###autoload
 (defun facemenu-read-color (&optional prompt)
   "Read a color using the minibuffer."
@@ -682,10 +487,11 @@ of colors that the current display can handle."
 	(if (facemenu-color-equal (car l) (car (cdr l)))
 	    (setcdr l (cdr (cdr l)))
 	  (setq l (cdr l)))))
-    ;; Don't show more than what the display can handle.
-    (let ((lc (nthcdr (1- (display-color-cells)) list)))
-      (if lc
-	  (setcdr lc nil))))
+    (when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
+      ;; Don't show more than what the display can handle.
+      (let ((lc (nthcdr (1- (display-color-cells)) list)))
+	(if lc
+	    (setcdr lc nil)))))
   (with-output-to-temp-buffer "*Colors*"
     (save-excursion
       (set-buffer standard-output)
@@ -804,37 +610,24 @@ If not, create it and add it to the appropriate menu.  Return the SYMBOL."
 	  (t (make-face symbol))))
   symbol)
 
-(defun facemenu-add-new-face (face-or-color &optional menu)
-  "Add FACE-OR-COLOR (a face or a color) to the appropriate Face menu.
-If MENU is nil, then FACE-OR-COLOR is a face to be added
-to `facemenu-face-menu'.  If MENU is `facemenu-foreground-menu'
-or `facemenu-background-menu', FACE-OR-COLOR is a color
-to be added to the specified menu.
+(defun facemenu-add-new-face (face)
+  "Add FACE (a face) to the Face menu.
 
 This is called whenever you create a new face."
   (let* (name
 	 symbol
-	 docstring
-	 (key (cdr (assoc face-or-color facemenu-keybindings)))
+	 menu docstring
+	 (key (cdr (assoc face facemenu-keybindings)))
 	 function menu-val)
-    (if (symbolp face-or-color)
-	(setq name (symbol-name face-or-color)
-	      symbol face-or-color)
-      (setq name face-or-color
+    (if (symbolp face)
+	(setq name (symbol-name face)
+	      symbol face)
+      (setq name face
 	    symbol (intern name)))
-    (cond ((eq menu 'facemenu-foreground-menu)
-	   (setq docstring
-		 (format "Select foreground color %s for subsequent insertion."
-			 name)))
-	  ((eq menu 'facemenu-background-menu)
-	   (setq docstring
-		 (format "Select background color %s for subsequent insertion."
-			 name)))
-	  (t
-	   (setq menu 'facemenu-face-menu)
-	   (setq docstring
-		 (format "Select face `%s' for subsequent insertion."
-			 name))))
+    (setq menu 'facemenu-face-menu)
+    (setq docstring
+	  (format "Select face `%s' for subsequent insertion."
+		  name))
     (cond ((eq t facemenu-unlisted-faces))
 	  ((memq symbol facemenu-unlisted-faces))
 	  ;; test against regexps in facemenu-unlisted-faces
@@ -876,6 +669,48 @@ This is called whenever you create a new face."
 	     (define-key menu key (cons name function))))))
   nil) ; Return nil for facemenu-iterate
 
+(defun facemenu-add-new-color (color &optional menu)
+  "Add COLOR (a color name string) to the appropriate Face menu.
+MENU should be `facemenu-foreground-menu' or
+`facemenu-background-menu'.
+
+This is called whenever you use a new color."
+  (let* (name
+	 symbol
+	 docstring
+	 function menu-val key
+	 (color-p (memq menu '(facemenu-foreground-menu
+			       facemenu-background-menu))))
+    (unless (stringp color)
+      (error "%s is not a color" color))
+    (setq name color
+	  symbol (intern name))
+
+    (cond ((eq menu 'facemenu-foreground-menu)
+	   (setq docstring
+		 (format "Select foreground color %s for subsequent insertion."
+			 name)))
+	  ((eq menu 'facemenu-background-menu)
+	   (setq docstring
+		 (format "Select background color %s for subsequent insertion."
+			 name))))
+    (cond ((facemenu-iterate ; check if equivalent face is already in the menu
+	    (lambda (m) (and (listp m) 
+			     (symbolp (car m))
+			     (stringp (cadr m))
+			     (string-equal (cadr m) color)))
+	    (cdr (symbol-function menu))))
+	  (t   ; No keyboard equivalent.  Figure out where to put it:
+	   (setq key (vector symbol)
+		 function 'facemenu-set-face-from-menu
+		 menu-val (symbol-function menu))
+	   (if (and facemenu-new-faces-at-end
+		   (> (length menu-val) 3))
+	       (define-key-after menu-val key (cons name function)
+		 (car (nth (- (length menu-val) 3) menu-val)))
+	     (define-key menu key (cons name function))))))
+  nil) ; Return nil for facemenu-iterate
+
 (defun facemenu-complete-face-list (&optional oldlist)
   "Return list of all faces that look different.
 Starts with given ALIST of faces, and adds elements only if they display