comparison lisp/facemenu.el @ 13923:35e379a3952e

(facemenu-read-color, list-colors-display) (facemenu-get-face): Treat all non-nil window-system values alike. (facemenu-color-equal): Special case for MSDOS.

13922:5636ed4243ec

  "Keymap for face-changing commands.
`Facemenu-update' fills in the keymap according to the bindings
requested in `facemenu-keybindings'.")
(defalias 'facemenu-keymap facemenu-keymap)

;;; Internal Variables

(defvar facemenu-color-alist nil
  ;; Don't initialize here; that doesn't work if preloaded.
  "Alist of colors, used for completion.

  (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-self-insert-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).

			 (region-end))))
  (barf-if-buffer-read-only)
  (facemenu-get-face face)
  (if start 
      (facemenu-add-face face start end)
    (facemenu-self-insert-face face)))

(defun facemenu-self-insert-face (face)
  (setq self-insert-face (if (eq last-command self-insert-face-command)
			     (cons face (if (listp self-insert-face)
					    self-insert-face
					  (list self-insert-face)))
			   face)
	self-insert-face-command this-command))

;;;###autoload
(defun facemenu-set-invisible (start end)
  "Make the region invisible.
This sets the `invisible' text property; it can be undone with

;;;###autoload
(defun list-text-properties-at (p)
  "Pop up a buffer listing text-properties at LOCATION."
  (interactive "d")
  (let ((props (text-properties-at p)))
    (if (null props)
	(message "None")
      (with-output-to-temp-buffer "*Text Properties*"
	(princ (format "Text properties at %d:\n\n" p))
	(while props
	  (princ (format "%-20s %S\n"
			 (car props) (car (cdr props))))
	  (setq props (cdr (cdr props))))))))

;;;###autoload
(defun facemenu-read-color (&optional prompt)
  "Read a color using the minibuffer."
  (let ((col (completing-read (or prompt "Color: ") 
			      (or facemenu-color-alist
				  (if (or (eq window-system 'x) (eq window-system 'win32))
				      (mapcar 'list (x-defined-colors))))
			      nil t)))
    (if (equal "" col)
	nil
      col)))

  "Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
colors to display.  Otherwise, this command computes a list
of colors that the current display can handle."
  (interactive)
  (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32)))
      (progn
	(setq list (x-defined-colors))
	;; Delete duplicate colors.
	(let ((l list))
	  (while (cdr l)

This function queries the window-system server to find out what the
color names mean.  It returns nil if the colors differ or if it can't
determine the correct answer."
  (cond ((equal a b) t)
	((and (or (eq window-system 'x) (eq window-system 'win32))
	      (equal (x-color-values a) (x-color-values b))))))

(defun facemenu-add-face (face start end)
  "Add FACE to text between START and END.
For each section of that region that has a different face property, FACE will
be consed onto it, and other faces that are completely hidden by that will be
removed from the list.

As a special case, if FACE is `default', then the region is left with NO face
text property.  Otherwise, selecting the default face would not have any
effect."
  (interactive "*xFace:\nr")
  (if (eq face 'default)
      (remove-text-properties start end '(face default))
    (let ((part-start start) part-end)
      (while (not (= part-start end))
	(setq part-end (next-single-property-change part-start 'face nil end))
	(let ((prev (get-text-property part-start 'face)))
	  (put-text-property part-start part-end 'face
			     (if (null prev)
				 face
			       (facemenu-active-faces
				(cons face
				      (if (listp prev) prev (list prev)))))))
	(setq part-start part-end)))))

(defun facemenu-active-faces (face-list &optional frame)
  "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.

	  (let* ((face (make-face symbol))
		 (name (symbol-name symbol))
		 (color (substring name 3)))
	    (cond ((string-match "^fg:" name)
		   (set-face-foreground face color)
		   (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color)))
		  ((string-match "^bg:" name)
		   (set-face-background face color)
		   (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color)))
		  (t))))
      symbol))

(defun facemenu-add-new-face (face)
  "Add a FACE to the appropriate Face menu.

13923:35e379a3952e

  "Keymap for face-changing commands.
`Facemenu-update' fills in the keymap according to the bindings
requested in `facemenu-keybindings'.")
(defalias 'facemenu-keymap facemenu-keymap)


(defvar facemenu-add-face-function nil
  "Function called at beginning of text to change or `nil'.
This function is passed the FACE to set and END of text to change, and must
return a string which is inserted.  It may set `facemenu-end-add-face'.")

(defvar facemenu-end-add-face nil
  "String to insert or function called at end of text to change or `nil'.
This function is passed the FACE to set, and must return a string which is
inserted.")

(defvar facemenu-remove-face-function nil
  "When non-`nil' function called to remove faces.
This function is passed the START and END of text to change.
May also be `t' meaning to use `facemenu-add-face-function'.")

;;; Internal Variables

(defvar facemenu-color-alist nil
  ;; Don't initialize here; that doesn't work if preloaded.
  "Alist of colors, used for completion.

  (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).

			 (region-end))))
  (barf-if-buffer-read-only)
  (facemenu-get-face face)
  (if start 
      (facemenu-add-face face start end)
    (facemenu-add-face face)))

;;;###autoload
(defun facemenu-set-invisible (start end)
  "Make the region invisible.
This sets the `invisible' text property; it can be undone with

;;;###autoload
(defun list-text-properties-at (p)
  "Pop up a buffer listing text-properties at LOCATION."
  (interactive "d")
  (let ((props (text-properties-at p))
	str)
    (if (null props)
	(message "None")
      (if (and (not (cdr (cdr props)))
	       (< (length (setq str (format "Text property at %d:  %s  %S"
					    p (car props) (car (cdr props)))))
		  (frame-width)))
	  (message str)
	(with-output-to-temp-buffer "*Text Properties*"
	  (princ (format "Text properties at %d:\n\n" p))
	  (while props
	    (princ (format "%-20s %S\n"
			   (car props) (car (cdr props))))
	    (setq props (cdr (cdr props)))))))))

;;;###autoload
(defun facemenu-read-color (&optional prompt)
  "Read a color using the minibuffer."
  (let ((col (completing-read (or prompt "Color: ") 
			      (or facemenu-color-alist
				  (if window-system
				      (mapcar 'list (x-defined-colors))))
			      nil t)))
    (if (equal "" col)
	nil
      col)))

  "Display names of defined colors, and show what they look like.
If the optional argument LIST is non-nil, it should be a list of
colors to display.  Otherwise, this command computes a list
of colors that the current display can handle."
  (interactive)
  (if (and (null list) window-system)
      (progn
	(setq list (x-defined-colors))
	;; Delete duplicate colors.
	(let ((l list))
	  (while (cdr l)

This function queries the window-system server to find out what the
color names mean.  It returns nil if the colors differ or if it can't
determine the correct answer."
  (cond ((equal a b) t)
	((and (or (eq window-system 'x) (eq window-system 'win32))
	      (equal (x-color-values a) (x-color-values b))))
	((eq window-system 'pc)
	 (and (x-color-defined-p a) (x-color-defined-p b)
	      (eq (msdos-color-translate a) (msdos-color-translate b))))))

(defun facemenu-add-face (face &optional start end)
  "Add FACE to text between START and END.
If START is `nil' or START to END is empty, add FACE to next typed character
instead.  For each section of that region that has a different face property,
FACE will be consed onto it, and other faces that are completely hidden by
that will be removed from the list.
If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-`nil'
they are used to set the face information.

As a special case, if FACE is `default', then the region is left with NO face
text property.  Otherwise, selecting the default face would not have any
effect.  See `facemenu-remove-face-function'."
  (interactive "*xFace: \nr")
  (if (and (eq face 'default)
	   (not (eq facemenu-remove-face-function t)))
      (if facemenu-remove-face-function
	  (funcall facemenu-remove-face-function start end)
	(remove-text-properties start end '(face default)))
    (if facemenu-add-face-function
	(save-excursion
	  (if end (goto-char end))
	  (save-excursion
	    (if start (goto-char start))
	    (insert-before-markers
	     (funcall facemenu-add-face-function face end)))
	  (if facemenu-end-add-face
	      (insert (if (stringp facemenu-end-add-face)
			  facemenu-end-add-face
			(funcall facemenu-end-add-face face)))))
      (if (and start (< start end))
	  (let ((part-start start) part-end)
	    (while (not (= part-start end))
	      (setq part-end (next-single-property-change part-start 'face
							  nil end))
	      (let ((prev (get-text-property part-start 'face)))
		(put-text-property part-start part-end 'face
				   (if (null prev)
				       face
				     (facemenu-active-faces
				      (cons face
					    (if (listp prev)
						prev
					      (list prev)))))))
	      (setq part-start part-end)))
	(setq self-insert-face (if (eq last-command self-insert-face-command)
				   (cons face (if (listp self-insert-face)
						  self-insert-face
						(list self-insert-face)))
				 face)
	      self-insert-face-command this-command)))))

(defun facemenu-active-faces (face-list &optional frame)
  "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.

	  (let* ((face (make-face symbol))
		 (name (symbol-name symbol))
		 (color (substring name 3)))
	    (cond ((string-match "^fg:" name)
		   (set-face-foreground face color)
		   (and window-system
			(x-color-defined-p color)))
		  ((string-match "^bg:" name)
		   (set-face-background face color)
		   (and window-system
			(x-color-defined-p color)))
		  (t))))
      symbol))

(defun facemenu-add-new-face (face)
  "Add a FACE to the appropriate Face menu.