;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
(eval-when-compile
(require 'cl))
-(declare-function xw-defined-colors "term/x-win" (&optional frame))
+(declare-function xw-defined-colors "term/common-win" (&optional frame))
(defvar help-xref-stack-item)
`:height'
-VALUE must be either an integer specifying the height of the font to use
-in 1/10 pt, a floating point number specifying the amount by which to
-scale any underlying face, or a function, which is called with the old
-height (from the underlying face), and should return the new height.
+VALUE specifies the height of the font, in either absolute or relative
+terms. An absolute height is an integer, and specifies font height in
+units of 1/10 pt. A relative height is either a floating point number,
+which specifies a scaling factor for the underlying face height;
+or a function that takes a single argument (the underlying face height)
+and returns the new height. Note that for the `default' face,
+you can only specify an absolute height (since there is nothing
+for it to be relative to).
`:weight'
(defun face-spec-reset-face (face &optional frame)
"Reset all attributes of FACE on FRAME to unspecified."
- (let ((attrs face-attribute-name-alist))
- (while attrs
- (let ((attr-and-name (car attrs)))
- (set-face-attribute face frame (car attr-and-name) 'unspecified))
- (setq attrs (cdr attrs)))))
-
+ (let (reset-args)
+ (dolist (attr-and-name face-attribute-name-alist)
+ (push 'unspecified reset-args)
+ (push (car attr-and-name) reset-args))
+ (apply 'set-face-attribute face frame reset-args)))
(defun face-spec-set (face spec &optional for-defface)
"Set FACE's face spec, which controls its appearance, to SPEC.
is used. If nil or omitted, use the selected frame."
(unless frame
(setq frame (selected-frame)))
- (let ((list face-attribute-name-alist)
- (match t))
- (while (and match (not (null list)))
- (let* ((attr (car (car list)))
+ (let* ((list face-attribute-name-alist)
+ (match t)
+ (bold (and (plist-member attrs :bold)
+ (not (plist-member attrs :weight))))
+ (italic (and (plist-member attrs :italic)
+ (not (plist-member attrs :slant))))
+ (plist (if (or bold italic)
+ (copy-sequence attrs)
+ attrs)))
+ ;; Handle the Emacs 20 :bold and :italic properties.
+ (if bold
+ (plist-put plist :weight (if bold 'bold 'normal)))
+ (if italic
+ (plist-put plist :slant (if italic 'italic 'normal)))
+ (while (and match list)
+ (let* ((attr (caar list))
(specified-value
- (if (plist-member attrs attr)
- (plist-get attrs attr)
+ (if (plist-member plist attr)
+ (plist-get plist attr)
'unspecified))
(value-now (face-attribute face attr frame)))
(setq match (equal specified-value value-now))
(setq list (cdr list))))
match))
-(defun face-spec-match-p (face spec &optional frame)
+(defsubst face-spec-match-p (face spec &optional frame)
"Return t if FACE, on FRAME, matches what SPEC says it should look like."
(face-attr-match-p face (face-spec-choose spec frame) frame))
(t
(> (tty-color-gray-shades display) 2)))))
-(defun read-color (&optional prompt convert-to-RGB-p allow-empty-name-p msg-p)
- "Read a color name or RGB hex value: #RRRRGGGGBBBB.
-Completion is available for color names, but not for RGB hex strings.
-If the user inputs an RGB hex string, it must have the form
-#XXXXXXXXXXXX or XXXXXXXXXXXX, where each X is a hex digit. The
-number of Xs must be a multiple of 3, with the same number of Xs for
-each of red, green, and blue. The order is red, green, blue.
+(defun read-color (&optional prompt convert-to-RGB allow-empty-name msg)
+ "Read a color name or RGB triplet of the form \"#RRRRGGGGBBBB\".
+Completion is available for color names, but not for RGB triplets.
+
+RGB triplets have the form #XXXXXXXXXXXX, where each X is a hex
+digit. The number of Xs must be a multiple of 3, with the same
+number of Xs for each of red, green, and blue. The order is red,
+green, blue.
-In addition to standard color names and RGB hex values, the following
-are available as color candidates. In each case, the corresponding
-color is used.
+In addition to standard color names and RGB hex values, the
+following are available as color candidates. In each case, the
+corresponding color is used.
* `foreground at point' - foreground under the cursor
* `background at point' - background under the cursor
-Checks input to be sure it represents a valid color. If not, raises
-an error (but see exception for empty input with non-nil
-ALLOW-EMPTY-NAME-P).
-
-Optional arg PROMPT is the prompt; if nil, uses a default prompt.
+Optional arg PROMPT is the prompt; if nil, use a default prompt.
-Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts
-an input color name to an RGB hex string. Returns the RGB hex string.
+Interactively, or with optional arg CONVERT-TO-RGB-P non-nil,
+convert an input color name to an RGB hex string. Return the RGB
+hex string.
-Optional arg ALLOW-EMPTY-NAME-P controls what happens if the user
-enters an empty color name (that is, just hits `RET'). If non-nil,
-then returns an empty color name, \"\". If nil, then raises an error.
-Programs must test for \"\" if ALLOW-EMPTY-NAME-P is non-nil. They
-can then perform an appropriate action in case of empty input.
+If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
+to enter an empty color name (the empty string).
-Interactively, or with optional arg MSG-P non-nil, echoes the color in
-a message."
+Interactively, or with optional arg MSG non-nil, print the
+resulting color name in the echo area."
(interactive "i\np\ni\np") ; Always convert to RGB interactively.
(let* ((completion-ignore-case t)
- (colors (append '("foreground at point" "background at point")
- (defined-colors)))
- (color (completing-read (or prompt "Color (name or #R+G+B+): ")
- colors))
- hex-string)
- (cond ((string= "foreground at point" color)
- (setq color (foreground-color-at-point)))
- ((string= "background at point" color)
- (setq color (background-color-at-point))))
- (unless color
- (setq color ""))
- (setq hex-string
- (string-match "^#?\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color))
- (if (and allow-empty-name-p (string= "" color))
- ""
- (when (and hex-string (not (eq (aref color 0) ?#)))
- (setq color (concat "#" color))) ; No #; add it.
- (unless hex-string
- (when (or (string= "" color) (not (test-completion color colors)))
- (error "No such color: %S" color))
- (when convert-to-RGB-p
- (let ((components (x-color-values color)))
- (unless components (error "No such color: %S" color))
- (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
- (setq color (format "#%04X%04X%04X"
- (logand 65535 (nth 0 components))
- (logand 65535 (nth 1 components))
- (logand 65535 (nth 2 components))))))))
- (when msg-p (message "Color: `%s'" color))
- color)))
-
-;; Commented out because I decided it is better to include the
-;; duplicates in read-color's completion list.
-
-;; (defun defined-colors-without-duplicates ()
-;; "Return the list of defined colors, without the no-space versions.
-;; For each color name, we keep the variant that DOES have spaces."
-;; (let ((result (copy-sequence (defined-colors)))
-;; to-be-rejected)
-;; (save-match-data
-;; (dolist (this result)
-;; (if (string-match " " this)
-;; (push (replace-regexp-in-string " " ""
-;; this)
-;; to-be-rejected)))
-;; (dolist (elt to-be-rejected)
-;; (let ((as-found (car (member-ignore-case elt result))))
-;; (setq result (delete as-found result)))))
-;; result))
+ (colors (or facemenu-color-alist
+ (append '("foreground at point" "background at point")
+ (if allow-empty-name '(""))
+ (defined-colors))))
+ (color (completing-read
+ (or prompt "Color (name or #RGB triplet): ")
+ ;; Completing function for reading colors, accepting
+ ;; both color names and RGB triplets.
+ (lambda (string pred flag)
+ (cond
+ ((null flag) ; Try completion.
+ (or (try-completion string colors pred)
+ (if (color-defined-p string)
+ string)))
+ ((eq flag t) ; List all completions.
+ (or (all-completions string colors pred)
+ (if (color-defined-p string)
+ (list string))))
+ ((eq flag 'lambda) ; Test completion.
+ (or (memq string colors)
+ (color-defined-p string)))))
+ nil t))
+ hex-string)
+
+ ;; Process named colors.
+ (when (member color colors)
+ (cond ((string-equal color "foreground at point")
+ (setq color (foreground-color-at-point)))
+ ((string-equal color "background at point")
+ (setq color (background-color-at-point))))
+ (when (and convert-to-RGB
+ (not (string-equal color "")))
+ (let ((components (x-color-values color)))
+ (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
+ (setq color (format "#%04X%04X%04X"
+ (logand 65535 (nth 0 components))
+ (logand 65535 (nth 1 components))
+ (logand 65535 (nth 2 components))))))))
+ (when msg (message "Color: `%s'" color))
+ color))
+
(defun face-at-point ()
"Return the face of the character after point.
(defvar inhibit-frame-set-background-mode nil)
-(defun frame-set-background-mode (frame)
+(defun frame-set-background-mode (frame &optional keep-face-specs)
"Set up display-dependent faces on FRAME.
Display-dependent faces are those which have different definitions
-according to the `background-mode' and `display-type' frame parameters."
+according to the `background-mode' and `display-type' frame parameters.
+
+If optional arg KEEP-FACE-SPECS is non-nil, don't recalculate
+face specs for the new background mode."
(unless inhibit-frame-set-background-mode
(let* ((bg-resource
(and (window-system frame)
(let ((locally-modified-faces nil)
;; Prevent face-spec-recalc from calling this function
;; again, resulting in a loop (bug#911).
- (inhibit-frame-set-background-mode t))
- ;; Before modifying the frame parameters, collect a list of
- ;; faces that don't match what their face-spec says they
- ;; should look like. We then avoid changing these faces
- ;; below. These are the faces whose attributes were
- ;; modified on FRAME. We use a negative list on the
- ;; assumption that most faces will be unmodified, so we can
- ;; avoid consing in the common case.
- (dolist (face (face-list))
- (and (not (get face 'face-override-spec))
- (not (face-spec-match-p face
- (face-user-default-spec face)
- (selected-frame)))
- (push face locally-modified-faces)))
- ;; Now change to the new frame parameters
- (modify-frame-parameters frame
- (list (cons 'background-mode bg-mode)
- (cons 'display-type display-type)))
- ;; For all named faces, choose face specs matching the new frame
- ;; parameters, unless they have been locally modified.
- (dolist (face (face-list))
- (unless (memq face locally-modified-faces)
- (face-spec-recalc face frame))))))))
+ (inhibit-frame-set-background-mode t)
+ (params (list (cons 'background-mode bg-mode)
+ (cons 'display-type display-type))))
+ (if keep-face-specs
+ (modify-frame-parameters frame params)
+ ;; If we are recomputing face specs, first collect a list
+ ;; of faces that don't match their face-specs. These are
+ ;; the faces modified on FRAME, and we avoid changing them
+ ;; below. Use a negative list to avoid consing (we assume
+ ;; most faces are unmodified).
+ (dolist (face (face-list))
+ (and (not (get face 'face-override-spec))
+ (not (face-spec-match-p face
+ (face-user-default-spec face)
+ (selected-frame)))
+ (push face locally-modified-faces)))
+ ;; Now change to the new frame parameters
+ (modify-frame-parameters frame params)
+ ;; For all unmodified named faces, choose face specs
+ ;; matching the new frame parameters.
+ (dolist (face (face-list))
+ (unless (memq face locally-modified-faces)
+ (face-spec-recalc face frame)))))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(list (cons 'cursor-color fg)))))))
(declare-function x-create-frame "xfns.c" (parms))
-(declare-function x-setup-function-keys "term/x-win" (frame))
+(declare-function x-setup-function-keys "term/common-win" (frame))
(defun x-create-frame-with-faces (&optional parameters)
"Create and return a frame with frame parameters PARAMETERS.
(progn
(x-setup-function-keys frame)
(x-handle-reverse-video frame parameters)
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
(if (null visibility-spec)
(make-frame-visible frame)
settings, X resources, and `face-new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
frame parameters in PARAMETERS."
- (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
- (condition-case ()
- (progn
- ;; Initialize faces from face spec and custom theme.
- (face-spec-recalc face frame)
- ;; X resouces for the default face are applied during
- ;; x-create-frame.
- (and (not (eq face 'default))
- (memq (window-system frame) '(x w32))
- (make-face-x-resource-internal face frame))
- ;; Apply attributes specified by face-new-frame-defaults
- (internal-merge-in-global-face face frame))
- ;; Don't let invalid specs prevent frame creation.
- (error nil)))
+ (let ((window-system-p (memq (window-system frame) '(x w32))))
+ (dolist (face (nreverse (face-list))) ;Why reverse? --Stef
+ (condition-case ()
+ (progn
+ ;; Initialize faces from face spec and custom theme.
+ (face-spec-recalc face frame)
+ ;; X resouces for the default face are applied during
+ ;; `x-create-frame'.
+ (and (not (eq face 'default)) window-system-p
+ (make-face-x-resource-internal face frame))
+ ;; Apply attributes specified by face-new-frame-defaults
+ (internal-merge-in-global-face face frame))
+ ;; Don't let invalid specs prevent frame creation.
+ (error nil))))
+
;; Apply attributes specified by frame parameters.
(let ((face-params '((foreground-color default :foreground)
(background-color default :background)
(set-terminal-parameter frame 'terminal-initted t)
(set-locale-environment nil frame)
(tty-run-terminal-initialization frame))
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame parameters)
(setq success t))
(unless success
(defun tty-set-up-initial-frame-faces ()
(let ((frame (selected-frame)))
- (frame-set-background-mode frame)
+ (frame-set-background-mode frame t)
(face-set-after-frame-default frame)))
:group 'frames
:group 'basic-faces)
-(defface cursor '((t nil))
+(defface cursor
+ '((((background light)) :background "black")
+ (((background dark)) :background "white"))
"Basic face for the cursor color under X.
Note: Other faces cannot inherit from the cursor face."
:version "21.1"
(defface help-argument-name '((((supports :slant italic)) :inherit italic))
"Face to highlight argument names in *Help* buffers."
:group 'help)
+
+(defface glyphless-char
+ '((((type tty)) :inherit underline)
+ (((type pc)) :inherit escape-glyph)
+ (t :height 0.6))
+ "Face for displaying non-graphic characters (e.g. U+202A (LRE)).
+It is used for characters of no fonts too."
+ :version "24.1"
+ :group 'basic-faces)
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulating font names.
(provide 'faces)
-;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6
;;; faces.el ends here
HCoop / bpt / emacs.git / blobdiff