;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1992-1996, 1998-2011 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
(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)
(defcustom face-font-selection-order
'(:width :height :weight :slant)
- "*A list specifying how face font selection chooses fonts.
+ "A list specifying how face font selection chooses fonts.
Each of the four symbols `:width', `:height', `:weight', and `:slant'
must appear once in the list, and the list must not contain any other
elements. Font selection first tries to find a best matching font
;; unavailable, and we fall back on the courier and helv families,
;; which are generally available.
(defcustom face-font-family-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
'(("Monospace" "courier" "fixed")
- ("courier" "fixed")
+ ("courier" "CMU Typewriter Text" "fixed")
("Sans Serif" "helv" "helvetica" "arial" "fixed")
- ("helv" "helvetica" "arial" "fixed"))
- "*Alist of alternative font family names.
+ ("helv" "helvetica" "arial" "fixed")))
+ "Alist of alternative font family names.
Each element has the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
ALTERNATIVE2 etc."
;; This is defined originally in xfaces.c.
(defcustom face-font-registry-alternatives
+ (mapcar (lambda (arg) (mapcar 'purecopy arg))
(if (eq system-type 'windows-nt)
'(("iso8859-1" "ms-oemlatin")
("gb2312.1980" "gb2312" "gbk" "gb18030")
'(("gb2312.1980" "gb2312.80&gb8565.88" "gbk" "gb18030")
("jisx0208.1990" "jisx0208.1983" "jisx0208.1978")
("ksc5601.1989" "ksx1001.1992" "ksc5601.1987")
- ("muletibetan-2" "muletibetan-0")))
- "*Alist of alternative font registry names.
+ ("muletibetan-2" "muletibetan-0"))))
+ "Alist of alternative font registry names.
Each element has the form (REGISTRY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of registry REGISTRY can be loaded, font selection
tries to find a best matching font among all fonts of registry
(internal-copy-lisp-face old-face new-face frame new-frame))
new-face))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Obsolete functions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; The functions in this section are defined because Lisp packages use
-;; them, despite the prefix `internal-' suggesting that they are
-;; private to the face implementation.
-
-(defun internal-find-face (name &optional frame)
- "Retrieve the face named NAME.
-Return nil if there is no such face.
-If NAME is already a face, it is simply returned.
-The optional argument FRAME is ignored."
- (facep name))
-(make-obsolete 'internal-find-face 'facep "21.1")
-
-
-(defun internal-get-face (name &optional frame)
- "Retrieve the face named NAME; error if there is none.
-If NAME is already a face, it is simply returned.
-The optional argument FRAME is ignored."
- (or (facep name)
- (check-face name)))
-(make-obsolete 'internal-get-face "see `facep' and `check-face'." "21.1")
-
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Predicates, type checks.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom face-x-resources
+ (mapcar
+ (lambda (arg)
+ ;; FIXME; can we purecopy some of the conses too?
+ (cons (car arg)
+ (cons (purecopy (car (cdr arg))) (purecopy (cdr (cdr arg))))))
'((:family (".attributeFamily" . "Face.AttributeFamily"))
(:foundry (".attributeFoundry" . "Face.AttributeFoundry"))
(:width (".attributeWidth" . "Face.AttributeWidth"))
(:bold (".attributeBold" . "Face.AttributeBold"))
(:italic (".attributeItalic" . "Face.AttributeItalic"))
(:font (".attributeFont" . "Face.AttributeFont"))
- (:inherit (".attributeInherit" . "Face.AttributeInherit")))
- "*List of X resources and classes for face attributes.
+ (:inherit (".attributeInherit" . "Face.AttributeInherit"))))
+ "List of X resources and classes for face attributes.
Each element has the form (ATTRIBUTE ENTRY1 ENTRY2...) where ATTRIBUTE is
the name of a face attribute, and each ENTRY is a cons of the form
\(RESOURCE . CLASS) with RESOURCE being the resource and CLASS being the
(defun set-face-attributes-from-resources (face frame)
"Set attributes of FACE from X resources for FRAME."
- (when (memq (framep frame) '(x w32 ns))
+ (when (memq (framep frame) '(x w32))
(dolist (definition face-x-resources)
(let ((attribute (car definition)))
(dolist (entry (cdr definition))
(defun face-all-attributes (face &optional frame)
"Return an alist stating the attributes of FACE.
Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
-Normally the value describes the default attributes,
+If FRAME is omitted or nil the value describes the default attributes,
but if you specify FRAME, the value describes the attributes
of FACE on FRAME."
(mapcar (lambda (pair)
(if alias
(progn
(setq doc (get alias 'face-documentation))
- (format "%s is an alias for the face `%s'.%s" face alias
+ (format "%s is an alias for the face `%s'.%s" face alias
(if doc (format "\n%s" doc)
"")))
(get face 'face-documentation))))
attribute is changed on all frames).
ARGS must come in pairs ATTRIBUTE VALUE. ATTRIBUTE must be a valid
-face attribute name. All attributes can be set to `unspecified';
+face attribute name. All attributes can be set to `unspecified';
this fact is not further mentioned below.
The following attributes are recognized:
`: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'
VALUE is the name of a face from which to inherit attributes, or a list
of face names. Attributes from inherited faces are merged into the face
like an underlying face would be, with higher priority than underlying faces."
- (let ((where (if (null frame) 0 frame)))
- (setq args (purecopy args))
+ (setq args (purecopy args))
+ (let ((where (if (null frame) 0 frame))
+ (spec args)
+ family foundry)
;; If we set the new-frame defaults, this face is modified outside Custom.
(if (memq where '(0 t))
(put (or (get face 'face-alias) face) 'face-modified t))
+ ;; If family and/or foundry are specified, set it first. Certain
+ ;; face attributes, e.g. :weight semi-condensed, are not supported
+ ;; in every font. See bug#1127.
+ (while spec
+ (cond ((eq (car spec) :family)
+ (setq family (cadr spec)))
+ ((eq (car spec) :foundry)
+ (setq foundry (cadr spec))))
+ (setq spec (cddr spec)))
+ (when (or family foundry)
+ (when (and (stringp family)
+ (string-match "\\([^-]*\\)-\\([^-]*\\)" family))
+ (unless foundry
+ (setq foundry (match-string 1 family)))
+ (setq family (match-string 2 family)))
+ (when (or (stringp family) (eq family 'unspecified))
+ (internal-set-lisp-face-attribute face :family (purecopy family)
+ where))
+ (when (or (stringp foundry) (eq foundry 'unspecified))
+ (internal-set-lisp-face-attribute face :foundry (purecopy foundry)
+ where)))
(while args
- ;; Don't recursively set the attributes from the frame's font param
- ;; when we update the frame's font param from the attributes.
- (if (and (eq (car args) :family)
- (stringp (cadr args))
- (string-match "\\([^-]*\\)-\\([^-]*\\)" (cadr args)))
- (let ((foundry (match-string 1 (cadr args)))
- (family (match-string 2 (cadr args))))
- (internal-set-lisp-face-attribute face :foundry
- (purecopy foundry)
- where)
- (internal-set-lisp-face-attribute face :family
- (purecopy family)
- where))
+ (unless (memq (car args) '(:family :foundry))
(internal-set-lisp-face-attribute face (car args)
(purecopy (cadr args))
where))
- (setq args (cdr (cdr args))))))
-
+ (setq args (cddr args)))))
(defun make-face-bold (face &optional frame noerror)
"Make the font of FACE be bold, if possible.
;;; Interactively modifying faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun read-face-name (prompt &optional string-describing-default multiple)
+(defun read-face-name (prompt &optional default multiple)
"Read a face, defaulting to the face or faces on the char after point.
If it has the property `read-face-name', that overrides the `face' property.
PROMPT should be a string that describes what the caller will do with the face;
it should not end in a space.
-STRING-DESCRIBING-DEFAULT should describe what default the caller will use if
-the user just types RET; you can omit it.
+The optional argument DEFAULT provides the value to display in the
+minibuffer prompt that is returned if the user just types RET
+unless DEFAULT is a string (in which case nil is returned).
If MULTIPLE is non-nil, return a list of faces (possibly only one).
Otherwise, return a single face."
(let ((faceprop (or (get-char-property (point) 'read-face-name)
(let* ((input
;; Read the input.
(completing-read-multiple
- (if (or faces string-describing-default)
- (format "%s (default %s): " prompt
+ (if (or faces default)
+ (format "%s (default `%s'): " prompt
(if faces (mapconcat 'symbol-name faces ",")
- string-describing-default))
+ default))
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history
;; Canonicalize the output.
(output
(cond ((or (equal input "") (equal input '("")))
- faces)
+ (or faces (unless (stringp default) default)))
((stringp input)
(mapcar 'intern (split-string input ", *" t)))
((listp input)
(defun face-valid-attribute-values (attribute &optional frame)
"Return valid values for face attribute ATTRIBUTE.
The optional argument FRAME is used to determine available fonts
-and colors. If it is nil or not specified, the selected frame is
-used. Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value
-out of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
+and colors. If it is nil or not specified, the selected frame is used.
+Value is an alist of (NAME . VALUE) if ATTRIBUTE expects a value out
+of a set of discrete values. Value is `integerp' if ATTRIBUTE expects
an integer value."
(let ((valid
(case attribute
(:family
(if (window-system frame)
- (mapcar #'(lambda (x) (cons (symbol-name x) x))
+ (mapcar (lambda (x) (cons x x))
(font-family-list))
;; Only one font on TTYs.
(list (cons "default" "default"))))
((:height)
'integerp)
(:stipple
- (and (memq (window-system frame) '(x w32 ns))
+ (and (memq (window-system frame) '(x ns)) ; No stipple on w32
(mapcar #'list
(apply #'nconc
(mapcar (lambda (dir)
valid)))
-(defvar face-attribute-name-alist
+(defconst face-attribute-name-alist
'((:family . "font family")
(:foundry . "font foundry")
(:width . "character set width")
;;; Listing faces.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defvar list-faces-sample-text
+(defconst list-faces-sample-text
"abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"*Text string to display as the sample text for `list-faces-display'.")
(setq max-length (1+ max-length)
line-format (format "%%-%ds" max-length))
(with-help-window "*Faces*"
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
(setq truncate-lines t)
(insert
(substitute-command-keys
If the optional argument FRAME is given, report on face FACE in that frame.
If FRAME is t, report on the defaults for face FACE (for new frames).
If FRAME is omitted or nil, use the selected frame."
- (interactive (list (read-face-name "Describe face" "= `default' face" t)))
+ (interactive (list (read-face-name "Describe face" 'default t)))
(let* ((attrs '((:family . "Family")
(:foundry . "Foundry")
(:width . "Width")
(:inherit . "Inherit")))
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
attrs))))
- (help-setup-xref (list #'describe-face face) (interactive-p))
+ (help-setup-xref (list #'describe-face face)
+ (called-interactively-p 'interactive))
(unless face
(setq face 'default))
(if (not (listp face))
(setq face (list face)))
(with-help-window (help-buffer)
- (save-excursion
- (set-buffer standard-output)
+ (with-current-buffer standard-output
(dolist (f face)
(if (stringp f) (setq f (intern f)))
- (insert "Face: " (symbol-name f))
- (if (not (facep f))
- (insert " undefined face.\n")
- (let ((customize-label "customize this face")
- file-name)
- (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
- (princ (concat " (" customize-label ")\n"))
- (insert "Documentation: "
- (or (face-documentation f)
- "Not documented as a face.")
- "\n")
- (with-current-buffer standard-output
- (save-excursion
- (re-search-backward
- (concat "\\(" customize-label "\\)") nil t)
- (help-xref-button 1 'help-customize-face f)))
- (setq file-name (find-lisp-object-file-name f 'defface))
- (when file-name
- (princ "Defined in `")
- (princ (file-name-nondirectory file-name))
- (princ "'")
- ;; Make a hyperlink to the library.
- (save-excursion
- (re-search-backward "`\\([^`']+\\)'" nil t)
- (help-xref-button 1 'help-face-def f file-name))
- (princ ".")
- (terpri)
- (terpri))
- (dolist (a attrs)
- (let ((attr (face-attribute f (car a) frame)))
- (insert (make-string (- max-width (length (cdr a))) ?\s)
- (cdr a) ": " (format "%s" attr))
- (if (and (eq (car a) :inherit)
- (not (eq attr 'unspecified)))
- ;; Make a hyperlink to the parent face.
- (save-excursion
- (re-search-backward ": \\([^:]+\\)" nil t)
- (help-xref-button 1 'help-face attr)))
- (insert "\n")))))
- (terpri))))))
+ ;; We may get called for anonymous faces (i.e., faces
+ ;; expressed using prop-value plists). Those can't be
+ ;; usefully customized, so ignore them.
+ (when (symbolp f)
+ (insert "Face: " (symbol-name f))
+ (if (not (facep f))
+ (insert " undefined face.\n")
+ (let ((customize-label "customize this face")
+ file-name)
+ (insert (concat " (" (propertize "sample" 'font-lock-face f) ")"))
+ (princ (concat " (" customize-label ")\n"))
+ ;; FIXME not sure how much of this belongs here, and
+ ;; how much in `face-documentation'. The latter is
+ ;; not used much, but needs to return nil for
+ ;; undocumented faces.
+ (let ((alias (get f 'face-alias))
+ (face f)
+ obsolete)
+ (when alias
+ (setq face alias)
+ (insert
+ (format "\n %s is an alias for the face `%s'.\n%s"
+ f alias
+ (if (setq obsolete (get f 'obsolete-face))
+ (format " This face is obsolete%s; use `%s' instead.\n"
+ (if (stringp obsolete)
+ (format " since %s" obsolete)
+ "")
+ alias)
+ ""))))
+ (insert "\nDocumentation:\n"
+ (or (face-documentation face)
+ "Not documented as a face.")
+ "\n\n"))
+ (with-current-buffer standard-output
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 'help-customize-face f)))
+ (setq file-name (find-lisp-object-file-name f 'defface))
+ (when file-name
+ (princ "Defined in `")
+ (princ (file-name-nondirectory file-name))
+ (princ "'")
+ ;; Make a hyperlink to the library.
+ (save-excursion
+ (re-search-backward "`\\([^`']+\\)'" nil t)
+ (help-xref-button 1 'help-face-def f file-name))
+ (princ ".")
+ (terpri)
+ (terpri))
+ (dolist (a attrs)
+ (let ((attr (face-attribute f (car a) frame)))
+ (insert (make-string (- max-width (length (cdr a))) ?\s)
+ (cdr a) ": " (format "%s" attr))
+ (if (and (eq (car a) :inherit)
+ (not (eq attr 'unspecified)))
+ ;; Make a hyperlink to the parent face.
+ (save-excursion
+ (re-search-backward ": \\([^:]+\\)" nil t)
+ (help-xref-button 1 'help-face attr)))
+ (insert "\n")))))
+ (terpri)))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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.
;; When we change a face based on a spec from outside custom,
;; record it for future frames.
(put (or (get face 'face-alias) face) 'face-override-spec spec))
-;;; RMS 29 dec 2007: Perhaps this code should be reinstated.
-;;; That depends on whether the overriding spec
-;;; or the default face attributes
-;;; should take priority.
-;;; ;; Clear all the new-frame default attributes for this face.
-;;; ;; face-spec-reset-face won't do it right.
-;;; (let ((facevec (cdr (assq face face-new-frame-defaults))))
-;;; (dotimes (i (length facevec))
-;;; (unless (= i 0)
-;;; (aset facevec i 'unspecified))))
;; Reset each frame according to the rules implied by all its specs.
(dolist (frame (frame-list))
(face-spec-recalc face frame))))
(defun face-spec-set-2 (face frame spec)
"Set the face attributes of FACE on FRAME according to SPEC."
- (let* ((attrs (face-spec-choose spec frame)))
- (while attrs
- (let ((attribute (car attrs))
- (value (car (cdr attrs))))
- ;; Support some old-style attribute names and values.
- (case attribute
- (:bold (setq attribute :weight value (if value 'bold 'normal)))
- (:italic (setq attribute :slant value (if value 'italic 'normal)))
- ((:foreground :background)
- ;; Compatibility with 20.x. Some bogus face specs seem to
- ;; exist containing things like `:foreground nil'.
- (if (null value) (setq value 'unspecified)))
- (t (unless (assq attribute face-x-resources)
- (setq attribute nil))))
- (when attribute
- (set-face-attribute face frame attribute value)))
- (setq attrs (cdr (cdr attrs))))))
+ (let* ((spec (face-spec-choose spec frame))
+ attrs)
+ (while spec
+ (when (assq (car spec) face-x-resources)
+ (push (car spec) attrs)
+ (push (cadr spec) attrs))
+ (setq spec (cddr spec)))
+ (apply 'set-face-attribute face frame (nreverse attrs))))
(defun face-attr-match-p (face attrs &optional frame)
"Return t if attributes of FACE match values in plist ATTRS.
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, use a default prompt.
-Optional arg PROMPT is the prompt; if nil, uses a default prompt.
+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.
-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.
+If optional arg ALLOW-EMPTY-NAME is non-nil, the user is allowed
+to enter an empty color name (the empty 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.
-
-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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defcustom frame-background-mode nil
- "*The brightness of the background.
+ "The brightness of the background.
Set this to the symbol `dark' if your background color is dark,
`light' if your background is light, or nil (automatic by default)
if you want Emacs to examine the brightness for you. Don't set this
(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)
(bg-color (frame-parameter frame 'background-color))
(terminal-bg-mode (terminal-parameter frame 'background-mode))
(tty-type (tty-type frame))
+ (default-bg-mode
+ (if (or (window-system frame)
+ (and tty-type
+ (string-match "^\\(xterm\\|\\rxvt\\|dtterm\\|eterm\\)"
+ tty-type)))
+ 'light
+ 'dark))
+ (non-default-bg-mode (if (eq default-bg-mode 'light) 'dark 'light))
(bg-mode
(cond (frame-background-mode)
(bg-resource (intern (downcase bg-resource)))
(terminal-bg-mode)
- ((and (null (window-system frame))
- ;; Unspecified frame background color can only
- ;; happen on tty's.
- (member bg-color '(nil unspecified "unspecified-bg")))
- ;; There is no way to determine the background mode
- ;; automatically, so we make a guess based on the
- ;; terminal type.
- (if (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type))
- 'light
- 'dark))
((equal bg-color "unspecified-fg") ; inverted colors
- (if (and tty-type
- (string-match "^\\(xterm\\|rxvt\\|dtterm\\|eterm\\)"
- tty-type))
- 'dark
- 'light))
+ non-default-bg-mode)
+ ((not (color-values bg-color frame))
+ default-bg-mode)
((>= (apply '+ (color-values bg-color frame))
;; Just looking at the screen, colors whose
;; values add up to .6 of the white total
(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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun x-handle-named-frame-geometry (parameters)
"Add geometry parameters for a named frame to parameter list PARAMETERS.
Value is the new parameter list."
- (let* ((name (or (cdr (assq 'name parameters))
- (cdr (assq 'name default-frame-alist))))
- (x-resource-name name)
- (res-geometry (if name (x-get-resource "geometry" "Geometry"))))
- (when res-geometry
- (let ((parsed (x-parse-geometry res-geometry)))
- ;; If the resource specifies a position, call the position
- ;; and size "user-specified".
- (when (or (assq 'top parsed)
- (assq 'left parsed))
- (setq parsed (append '((user-position . t) (user-size . t)) parsed)))
- ;; Put the geometry parameters at the end. Copy
- ;; default-frame-alist so that they go after it.
- (setq parameters (append parameters default-frame-alist parsed))))
- parameters))
+ ;; Note that `x-resource-name' has a global meaning.
+ (let ((x-resource-name (cdr (assq 'name parameters))))
+ (when x-resource-name
+ ;; Before checking X resources, we must have an X connection.
+ (or (window-system)
+ (x-display-list)
+ (x-open-connection (or (cdr (assq 'display parameters))
+ x-display-name)))
+ (let (res-geometry parsed)
+ (and (setq res-geometry (x-get-resource "geometry" "Geometry"))
+ (setq parsed (x-parse-geometry res-geometry))
+ (setq parameters
+ (append parameters parsed
+ ;; If the resource specifies a position,
+ ;; take note of that.
+ (if (or (assq 'top parsed) (assq 'left parsed))
+ '((user-position . t) (user-size . t)))))))))
+ parameters)
(defun x-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter and X resource.
`x-create-frame' does not handle this one."
(when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
(let ((resource (x-get-resource "reverseVideo"
"ReverseVideo")))
(if resource
(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 tool-bar-setup "tool-bar" (&optional frame))
+(declare-function x-setup-function-keys "term/common-win" (frame))
(defun x-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If PARAMETERS specify a frame name,
-handle X geometry resources for that name. If either PARAMETERS
-or `default-frame-alist' contains a `reverse' parameter, or
-the X resource ``reverseVideo'' is present, handle that.
-Value is the new frame created."
+ "Create and return a frame with frame parameters PARAMETERS.
+If PARAMETERS specify a frame name, handle X geometry resources
+for that name. If PARAMETERS includes a `reverse' parameter, or
+the X resource ``reverseVideo'' is present, handle that."
(setq parameters (x-handle-named-frame-geometry parameters))
(let* ((params (copy-tree parameters))
(visibility-spec (assq 'visibility 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)
- ;; Make sure the tool-bar is ready to be enabled. The
- ;; `tool-bar-lines' frame parameter will not take effect
- ;; without this call.
- (when tool-bar-mode
- (tool-bar-setup frame))
(if (null visibility-spec)
(make-frame-visible frame)
(modify-frame-parameters frame (list visibility-spec)))
Calculate the face definitions using the face specs, custom theme
settings, X resources, and `face-new-frame-defaults'.
Finally, apply any relevant face attributes found amongst the
-frame parameters in PARAMETERS and `default-frame-alist'."
- (dolist (face (nreverse (face-list)))
- (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 ns))
- (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)))
+frame parameters in PARAMETERS."
+ (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)
(mouse-color mouse :background))))
(dolist (param face-params)
(let* ((param-name (nth 0 param))
- (value (cdr (or (assq param-name parameters)
- (assq param-name default-frame-alist)))))
+ (value (cdr (assq param-name parameters))))
(if value
(set-face-attribute (nth 1 param) frame
(nth 2 param) value))))))
(defun tty-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter for terminal frames."
- (when (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)))
+ (when (cdr (assq 'reverse parameters))
(let* ((params (frame-parameters frame))
(bg (cdr (assq 'foreground-color params)))
(fg (cdr (assq 'background-color params))))
(defun tty-create-frame-with-faces (&optional parameters)
- "Create a frame from optional frame parameters PARAMETERS.
-Parameters not specified by PARAMETERS are taken from
-`default-frame-alist'. If either PARAMETERS or `default-frame-alist'
-contains a `reverse' parameter, handle that. Value is the new frame
-created."
+ "Create and return a frame from optional frame parameters PARAMETERS.
+If PARAMETERS contains a `reverse' parameter, handle that."
(let ((frame (make-terminal-frame parameters))
success)
(unwind-protect
(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)))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Compatiblity with 20.2
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Update a frame's faces when we change its default font.
-
-(defalias 'frame-update-faces 'ignore "")
-(make-obsolete 'frame-update-faces "no longer necessary." "21.1")
-
-;; Update the colors of FACE, after FRAME's own colors have been
-;; changed.
-
-(define-obsolete-function-alias 'frame-update-face-colors
- 'frame-set-background-mode "21.1")
-
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Standard faces.
"Basic face for highlighting."
:group 'basic-faces)
+;; Region face: under NS, default to the system-defined selection
+;; color (optimized for the fixed white background of other apps),
+;; if background is light.
(defface region
'((((class color) (min-colors 88) (background dark))
:background "blue3")
+ (((class color) (min-colors 88) (background light) (type gtk))
+ :foreground "gtk_selection_fg_color"
+ :background "gtk_selection_bg_color")
+ (((class color) (min-colors 88) (background light) (type ns))
+ :background "ns_selection_color")
(((class color) (min-colors 88) (background light))
:background "lightgoldenrod2")
(((class color) (min-colors 16) (background dark))
:version "21.1"
:group 'mode-line-faces
:group 'basic-faces)
+;; No need to define aliases of this form for new faces.
+(define-obsolete-face-alias 'modeline 'mode-line "21.1")
(defface mode-line-inactive
'((default
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
+(define-obsolete-face-alias 'modeline-inactive 'mode-line-inactive "22.1")
(defface mode-line-highlight
'((((class color) (min-colors 88))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
+(define-obsolete-face-alias 'modeline-highlight 'mode-line-highlight "22.1")
(defface mode-line-emphasis
'((t (:weight bold)))
:version "22.1"
:group 'mode-line-faces
:group 'basic-faces)
-
-;; Make `modeline' an alias for `mode-line', for compatibility.
-(put 'modeline 'face-alias 'mode-line)
-(put 'modeline-inactive 'face-alias 'mode-line-inactive)
-(put 'modeline-highlight 'face-alias 'mode-line-highlight)
-(put 'modeline-buffer-id 'face-alias 'mode-line-buffer-id)
+(define-obsolete-face-alias 'modeline-buffer-id 'mode-line-buffer-id "22.1")
(defface header-line
'((default
: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"
:group 'menu
:group 'basic-faces)
+(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.
(encoding "[^-]+")
)
(setq x-font-regexp
- (concat "\\`\\*?[-?*]"
+ (purecopy (concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
pixelsize - pointsize - resx - resy - spacing - avgwidth -
registry - encoding "\\*?\\'"
- ))
+ )))
(setq x-font-regexp-head
- (concat "\\`[-?*]" foundry - family - weight\? - slant\?
- "\\([-*?]\\|\\'\\)"))
- (setq x-font-regexp-slant (concat - slant -))
- (setq x-font-regexp-weight (concat - weight -))
+ (purecopy (concat "\\`[-?*]" foundry - family - weight\? - slant\?
+ "\\([-*?]\\|\\'\\)")))
+ (setq x-font-regexp-slant (purecopy (concat - slant -)))
+ (setq x-font-regexp-weight (purecopy (concat - weight -)))
nil)
(car fonts))
(cdr (assq 'font (frame-parameters (selected-frame))))))
-
-(defun x-frob-font-weight (font which)
- (let ((case-fold-search t))
- (cond ((string-match x-font-regexp font)
- (concat (substring font 0
- (match-beginning x-font-regexp-weight-subnum))
- which
- (substring font (match-end x-font-regexp-weight-subnum)
- (match-beginning x-font-regexp-adstyle-subnum))
- ;; Replace the ADD_STYLE_NAME field with *
- ;; because the info in it may not be the same
- ;; for related fonts.
- "*"
- (substring font (match-end x-font-regexp-adstyle-subnum))))
- ((string-match x-font-regexp-head font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1))))
- ((string-match x-font-regexp-weight font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))))))
-(make-obsolete 'x-frob-font-weight 'make-face-... "21.1")
-
-(defun x-frob-font-slant (font which)
- (let ((case-fold-search t))
- (cond ((string-match x-font-regexp font)
- (concat (substring font 0
- (match-beginning x-font-regexp-slant-subnum))
- which
- (substring font (match-end x-font-regexp-slant-subnum)
- (match-beginning x-font-regexp-adstyle-subnum))
- ;; Replace the ADD_STYLE_NAME field with *
- ;; because the info in it may not be the same
- ;; for related fonts.
- "*"
- (substring font (match-end x-font-regexp-adstyle-subnum))))
- ((string-match x-font-regexp-head font)
- (concat (substring font 0 (match-beginning 2)) which
- (substring font (match-end 2))))
- ((string-match x-font-regexp-slant font)
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))))))
-(make-obsolete 'x-frob-font-slant 'make-face-... "21.1")
-
-;; These aliases are here so that we don't get warnings about obsolete
-;; functions from the byte compiler.
-(defalias 'internal-frob-font-weight 'x-frob-font-weight)
-(defalias 'internal-frob-font-slant 'x-frob-font-slant)
-
-(defun x-make-font-bold (font)
- "Given an X font specification, make a bold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "bold"))
-(make-obsolete 'x-make-font-bold 'make-face-bold "21.1")
-
-(defun x-make-font-demibold (font)
- "Given an X font specification, make a demibold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "demibold"))
-(make-obsolete 'x-make-font-demibold 'make-face-bold "21.1")
-
-(defun x-make-font-unbold (font)
- "Given an X font specification, make a non-bold version of it.
-If that can't be done, return nil."
- (internal-frob-font-weight font "medium"))
-(make-obsolete 'x-make-font-unbold 'make-face-unbold "21.1")
-
-(defun x-make-font-italic (font)
- "Given an X font specification, make an italic version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "i"))
-(make-obsolete 'x-make-font-italic 'make-face-italic "21.1")
-
-(defun x-make-font-oblique (font) ; you say tomayto...
- "Given an X font specification, make an oblique version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "o"))
-(make-obsolete 'x-make-font-oblique 'make-face-italic "21.1")
-
-(defun x-make-font-unitalic (font)
- "Given an X font specification, make a non-italic version of it.
-If that can't be done, return nil."
- (internal-frob-font-slant font "r"))
-(make-obsolete 'x-make-font-unitalic 'make-face-unitalic "21.1")
-
-(defun x-make-font-bold-italic (font)
- "Given an X font specification, make a bold and italic version of it.
-If that can't be done, return nil."
- (and (setq font (internal-frob-font-weight font "bold"))
- (internal-frob-font-slant font "i")))
-(make-obsolete 'x-make-font-bold-italic 'make-face-bold-italic "21.1")
-
(provide 'faces)
-;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6
;;; faces.el ends here
HCoop / bpt / emacs.git / blobdiff