(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")
(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
(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
(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)))))))))))
-
+\f
;;;###autoload
(defun facemenu-read-color (&optional prompt)
"Read a color using the minibuffer."
(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)
(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
(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