comparison lisp/facemenu.el @ 40275:113233ecd44a

(facemenu-unlisted-faces): Improve doc strings of t and nil values. (facemenu-set-face): Handle START and END interactively. (facemenu-set-foreground): Don't use a face; specify color directly. (facemenu-set-background): Likewise. (facemenu-set-face-from-menu): Doc fix. (facemenu-active-faces): Use face-attribute-vector to handle bare attributes not in faces. (facemenu-get-face): Don't handle face names fg:... and bg:... specially. (facemenu-add-new-face): New argument MENU. New way to handle adding colors to the color menus.

40274:d2e0c5832e0d

call `facemenu-update' to recalculate the menu contents.

If this variable is t, no faces will be added to the menu.  This is useful for
temporarily turning off the feature that automatically adds faces to the menu
when they are created."
  :type '(choice (const :tag "Don't add" t)
		 (const :tag "None" nil)
		 (repeat (choice symbol regexp)))
  :group 'facemenu)

;;;###autoload
(defvar facemenu-face-menu

		    (facemenu-complete-face-list facemenu-keybindings)))

;;;###autoload
(defun facemenu-set-face (face &optional start end)
  "Add FACE to the region or next character typed.
It will be added to the top of the face list; any faces lower on the list that
will not show through at all will be removed.

Interactively, the face to be used is read with the minibuffer.

In the Transient Mark mode, if the region is active and there is no
prefix argument, this command sets the region to the requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list (read-face-name "Use face")))
  (barf-if-buffer-read-only)
  (facemenu-add-new-face face)
  (if (and mark-active (not current-prefix-arg))
      (let ((start (or start (region-beginning)))
	    (end (or end (region-end))))
	(facemenu-add-face face start end))
    (facemenu-add-face face)))

;;;###autoload
(defun facemenu-set-foreground (color &optional start end)
  "Set the foreground COLOR of the region or next character typed.
The color is prompted for.  A face named `fg:color' is used \(or created).
If the region is active, it will be set to the requested face.  If
it is inactive \(even if mark-even-if-inactive is set) the next
character that is typed \(via `self-insert-command') will be set to
the selected face.  Moving point or switching buffers before
typing a character cancels the request." 
  (interactive (list (facemenu-read-color "Foreground color: ")))
  (let ((face (intern (concat "fg:" color))))
    (or (facemenu-get-face face)
	(error "Unknown color: %s" color))
    (facemenu-set-face face start end)))

;;;###autoload
(defun facemenu-set-background (color &optional start end)
  "Set the background COLOR of the region or next character typed.
The color is prompted for.  A face named `bg:color' is used \(or created).
If the region is active, it will be set to the requested face.  If
it is inactive \(even if mark-even-if-inactive is set) the next
character that is typed \(via `self-insert-command') will be set to
the selected face.  Moving point or switching buffers before
typing a character cancels the request." 
  (interactive (list (facemenu-read-color "Background color: ")))
  (let ((face (intern (concat "bg:" color))))
    (or (facemenu-get-face face)
	(error "Unknown color: %s" color))
    (facemenu-set-face face start end)))

;;;###autoload
(defun facemenu-set-face-from-menu (face start end)
  "Set the FACE of the region or next character typed.
This function is designed to be called from a menu; the face to use
is the menu item's name.

In the Transient Mark mode, if the region is active and there is no
prefix argument, this command sets the region to the requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list last-command-event

  "Return from FACE-LIST those faces that would be used for display.
This means each face attribute is not specified in a face earlier in FACE-LIST
and such a face is therefore active when used to display text.
If the optional argument FRAME is given, use the faces in that frame; otherwise
use the selected frame.  If t, then the global, non-frame faces are used."
  (let* ((mask-atts (copy-sequence (internal-get-face (car face-list) frame)))
	 (active-list (list (car face-list)))
	 (face-list (cdr face-list))
	 (mask-len (length mask-atts)))
    (while face-list
      (if (let ((face-atts (internal-get-face (car face-list) frame))
		(i mask-len) (useful nil))
	    (while (> (setq i (1- i)) 1)
	      (and (aref face-atts i) (not (aref mask-atts i))
		   (aset mask-atts i (setq useful t))))
	    useful)
	  (setq active-list (cons (car face-list) active-list)))
      (setq face-list (cdr face-list)))
    (nreverse active-list)))

(defun facemenu-get-face (symbol)
  "Make sure FACE exists.
If not, create it and add it to the appropriate menu.  Return the SYMBOL.

If a window system is in use, and this function creates a face named
`fg:color', then it sets the foreground to that color.  Likewise, `bg:color'
means to set the background.  In either case, if the color is undefined,
no color is set and a warning is issued."
  (let ((name (symbol-name symbol))
	foreground)
    (cond ((facep symbol))
	  ((and (display-color-p)
		(or (setq foreground (string-match "^fg:" name))
		    (string-match "^bg:" name)))
	   (let ((face (make-face symbol))
		 (color (substring name 3)))
	     (if (x-color-defined-p color)
		 (if foreground
		     (set-face-foreground face color)
		   (set-face-background face color))
	       (message "Color \"%s\" undefined" color))))
	  (t (make-face symbol))))
  symbol)

(defun facemenu-add-new-face (face)
  "Add a FACE to the appropriate Face menu.
Automatically called when a new face is created."
  (let* ((name (symbol-name face))
	 menu docstring
	 (key (cdr (assoc face facemenu-keybindings)))
	 function menu-val)
    (cond ((string-match "^fg:" name) 
	   (setq name (substring name 3))
	   (setq docstring
		 (format "Select foreground color %s for subsequent insertion."
			 name))
	   (setq menu 'facemenu-foreground-menu))
	  ((string-match "^bg:" name) 
	   (setq name (substring name 3))
	   (setq docstring
		 (format "Select background color %s for subsequent insertion."
			 name))
	   (setq menu 'facemenu-background-menu))
	  (t
	   (setq docstring
		 (format "Select face `%s' for subsequent insertion."
			 name))
	   (setq menu 'facemenu-face-menu)))
    (cond ((eq t facemenu-unlisted-faces))
	  ((memq face facemenu-unlisted-faces))
	  ;; test against regexps in facemenu-unlisted-faces
	  ((let ((unlisted facemenu-unlisted-faces)
		 (matched nil))
	     (while (and unlisted (not matched))
	       (if (and (stringp (car unlisted))

	   (setq function (intern (concat "facemenu-set-" name)))
	   (fset function
		 `(lambda ()
		    ,docstring
		    (interactive)
		    (facemenu-set-face (quote ,face))))
	   (define-key 'facemenu-keymap key (cons name function))
	   (define-key menu key (cons name function)))
	  ((facemenu-iterate ; check if equivalent face is already in the menu
	    (lambda (m) (and (listp m) 
			     (symbolp (car m))
			     (face-equal (car m) face)))
	    (cdr (symbol-function menu))))
	  (t   ; No keyboard equivalent.  Figure out where to put it:
	   (setq key (vector face)
		 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)

40275:113233ecd44a

call `facemenu-update' to recalculate the menu contents.

If this variable is t, no faces will be added to the menu.  This is useful for
temporarily turning off the feature that automatically adds faces to the menu
when they are created."
  :type '(choice (const :tag "Don't add faces" t)
		 (const :tag "None (do add any face)" nil)
		 (repeat (choice symbol regexp)))
  :group 'facemenu)

;;;###autoload
(defvar facemenu-face-menu

		    (facemenu-complete-face-list facemenu-keybindings)))

;;;###autoload
(defun facemenu-set-face (face &optional start end)
  "Add FACE to the region or next character typed.
This adds FACE to the top of the face list; any faces lower on the list that
will not show through at all will be removed.

Interactively, reads the face name with the minibuffer.

If the region is active (normally true except in Transient Mark mode)
and there is no prefix argument, this command sets the region to the
requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list (progn
		       (barf-if-buffer-read-only)
		       (read-face-name "Use face"))
		     (if (and mark-active (not current-prefix-arg))
			 (region-beginning))
		     (if (and mark-active (not current-prefix-arg))
			 (region-end))))
  (facemenu-add-new-face face)
  (facemenu-add-face face start end))

;;;###autoload
(defun facemenu-set-foreground (color &optional start end)
  "Set the foreground COLOR of the region or next character typed.
The color is prompted for.  A face named `fg:color' is used \(or created).

If the region is active (normally true except in Transient Mark mode)
and there is no prefix argument, this command sets the region to the
requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list (progn
		       (barf-if-buffer-read-only)
		       (facemenu-read-color "Foreground color: "))
		     (if (and mark-active (not current-prefix-arg))
			 (region-beginning))
		     (if (and mark-active (not current-prefix-arg))
			 (region-end))))
  (unless (color-defined-p color)
    (message "Color `%s' undefined" color))
  (facemenu-add-new-face color 'facemenu-foreground-menu)
  (facemenu-add-face (list (list :foreground color)) start end))

;;;###autoload
(defun facemenu-set-background (color &optional start end)
  "Set the background COLOR of the region or next character typed.
Reads the color in the minibuffer.

If the region is active (normally true except in Transient Mark mode)
and there is no prefix argument, this command sets the region to the
requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list (progn
		       (barf-if-buffer-read-only)
		       (facemenu-read-color "Background color: "))
		     (if (and mark-active (not current-prefix-arg))
			 (region-beginning))
		     (if (and mark-active (not current-prefix-arg))
			 (region-end))))
  (unless (color-defined-p color)
    (message "Color `%s' undefined" color))
  (facemenu-add-new-face color 'facemenu-background-menu)
  (facemenu-add-face (list (list :background color)) start end))

;;;###autoload
(defun facemenu-set-face-from-menu (face start end)
  "Set the FACE of the region or next character typed.
This function is designed to be called from a menu; the face to use
is the menu item's name.

If the region is active (normally true except in Transient Mark mode)
and there is no prefix argument, this command sets the region to the
requested face.

Otherwise, this command specifies the face for the next character
inserted.  Moving point or switching buffers before
typing a character to insert cancels the specification." 
  (interactive (list last-command-event

  "Return from FACE-LIST those faces that would be used for display.
This means each face attribute is not specified in a face earlier in FACE-LIST
and such a face is therefore active when used to display text.
If the optional argument FRAME is given, use the faces in that frame; otherwise
use the selected frame.  If t, then the global, non-frame faces are used."
  (let* ((mask-atts (copy-sequence
		     (if (consp (car face-list))
			 (face-attribute-vector (car face-list))
		       (or (internal-lisp-face-p (car face-list) frame)
			   (check-face (car face-list))))))
	 (active-list (list (car face-list)))
	 (face-list (cdr face-list))
	 (mask-len (length mask-atts)))
    (while face-list
      (if (let ((face-atts
		 (if (consp (car face-list))
		     (face-attribute-vector (car face-list))
		   (or (internal-lisp-face-p (car face-list) frame)
		       (check-face (car face-list)))))
		(i mask-len)
		(useful nil))
	    (while (> (setq i (1- i)) 1)
	      (and (not (memq (aref face-atts i) '(nil unspecified)))
		   (memq (aref mask-atts i) '(nil unspecified))
		   (aset mask-atts i (setq useful t))))
	    useful)
	  (setq active-list (cons (car face-list) active-list)))
      (setq face-list (cdr face-list)))
    (nreverse active-list)))

(defun facemenu-get-face (symbol)
  "Make sure FACE exists.
If not, create it and add it to the appropriate menu.  Return the SYMBOL."
  (let ((name (symbol-name symbol))
	foreground)
    (cond ((facep 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.

This is called whenever you create a new face."
  (let* (name
	 symbol
	 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
	    face (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))))
    (cond ((eq t facemenu-unlisted-faces))
	  ((memq symbol facemenu-unlisted-faces))
	  ;; test against regexps in facemenu-unlisted-faces
	  ((let ((unlisted facemenu-unlisted-faces)
		 (matched nil))
	     (while (and unlisted (not matched))
	       (if (and (stringp (car unlisted))

	   (setq function (intern (concat "facemenu-set-" name)))
	   (fset function
		 `(lambda ()
		    ,docstring
		    (interactive)
		    (facemenu-set-face (quote ,symbol))))
	   (define-key 'facemenu-keymap key (cons name function))
	   (define-key menu key (cons name function)))
	  ((facemenu-iterate ; check if equivalent face is already in the menu
	    (lambda (m) (and (listp m) 
			     (symbolp (car m))
			     (face-equal (car m) symbol)))
	    (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)