;;; faces.el --- Lisp faces
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
"*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 tries to find a best matching font for
-those face attributes first that appear first in the list. For
+elements. Font selection first tries to find a best matching font
+for those face attributes that appear before in the list. For
example, if `:slant' appears before `:height', font selection first
tries to find a font with a suitable slant, even if this results in
a font height that isn't optimal."
(defun internal-find-face (name &optional frame)
"Retrieve the face named NAME.
Return nil if there is no such face.
-If the optional argument FRAME is given, this gets the face NAME for
-that frame; otherwise, it uses the selected frame.
-If FRAME is the symbol t, then the global, non-frame face is returned.
-If NAME is already a face, it is simply returned."
+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 the optional argument FRAME is given, this gets the face NAME for
-that frame; otherwise, it uses the selected frame.
-If FRAME is the symbol t, then the global, non-frame face is returned.
-If NAME is already a face, it is simply returned."
+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")
(defun face-id (face &optional frame)
"Return the internal ID of face with name FACE.
+If FACE is a face-alias, return the ID of the target face.
The optional argument FRAME is ignored, since the internal face ID
of a face name is the same for all frames."
(check-face face)
- (get face 'face))
-
+ (or (get face 'face)
+ (face-id (get face 'face-alias))))
(defun face-equal (face1 face2 &optional frame)
"Non-nil if faces FACE1 and FACE2 are equal.
If FRAME is omitted or nil, use the selected frame."
(let ((attrs
'(:family :width :height :weight :slant :foreground
- :foreground :background :underline :overline
- :strike-through :box :inverse-video))
+ :background :underline :overline :strike-through
+ :box :inverse-video))
(differs nil))
(while (and attrs (not differs))
(let* ((attr (pop attrs))
(set-face-attribute face frame :stipple (or stipple 'unspecified)))
-(defun set-face-underline-p (face underline-p &optional frame)
+(defun set-face-underline-p (face underline &optional frame)
"Specify whether face FACE is underlined.
UNDERLINE nil means FACE explicitly doesn't underline.
UNDERLINE non-nil means FACE explicitly does underlining
(interactive
(let ((list (read-face-and-attribute :underline)))
(list (car list) (eq (car (cdr list)) t))))
- (set-face-attribute face frame :underline underline-p))
+ (set-face-attribute face frame :underline underline))
(define-obsolete-function-alias 'set-face-underline
'set-face-underline-p "22.1")
(nconc (mapcar #'(lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))
(mapcar #'(lambda (c) (cons c c))
- (x-defined-colors frame)))
+ (defined-colors frame)))
(mapcar #'(lambda (x) (cons (symbol-name x) x))
(internal-lisp-face-attribute-values attribute))))
((:foreground :background)
result))))))
(defun modify-face (&optional face foreground background stipple
- bold-p italic-p underline-p inverse-p frame)
+ bold-p italic-p underline inverse-p frame)
"Modify attributes of faces interactively.
If optional argument FRAME is nil or omitted, modify the face used
for newly created frame, i.e. the global face.
:stipple stipple
:bold bold-p
:italic italic-p
- :underline underline-p
+ :underline underline
:inverse-video inverse-p)
(setq face (read-face-name "Modify face"))
(apply #'set-face-attribute face frame
(error "No faces matching \"%s\"" regexp))
(setq max-length (1+ max-length)
line-format (format "%%-%ds" max-length))
- (with-output-to-temp-buffer "*Faces*"
+ (with-help-window "*Faces*"
(save-excursion
(set-buffer standard-output)
(setq truncate-lines t)
(while (not (eobp))
(insert-char ?\s max-length)
(forward-line 1))))
- (goto-char (point-min)))
- (print-help-return-message))
+ (goto-char (point-min))))
;; If the *Faces* buffer appears in a different frame,
;; copy all the face definitions from FRAME,
;; so that the display will reflect the frame that was selected.
(setq face 'default))
(if (not (listp face))
(setq face (list face)))
- (with-output-to-temp-buffer (help-buffer)
+ (with-help-window (help-buffer)
(save-excursion
(set-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")
(re-search-backward ": \\([^:]+\\)" nil t)
(help-xref-button 1 'help-face attr)))
(insert "\n")))))
- (terpri)))
- (print-help-return-message))))
+ (terpri))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun face-spec-set (face spec &optional frame)
"Set FACE's attributes according to the first matching entry in SPEC.
FRAME is the frame whose frame-local face is set. FRAME nil means
-do it on all frames. See `defface' for information about SPEC.
-If SPEC is nil, do nothing."
+do it on all frames (and change the default for new frames).
+See `defface' for information about SPEC. If SPEC is nil, do nothing."
(let ((attrs (face-spec-choose spec frame)))
(when spec
- (face-spec-reset-face face frame))
+ (face-spec-reset-face face (or frame t)))
(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))))
+ (: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)))
+ ;; If frame is nil, set the default for new frames.
+ ;; Existing frames are handled below.
+ (set-face-attribute face (or frame t) attribute value)))
(setq attrs (cdr (cdr attrs)))))
- ;; When we reset the face based on its spec, then it is unmodified
- ;; as far as Custom is concerned.
- (if (null frame)
- (put (or (get face 'face-alias) face) 'face-modified nil)))
+ (unless frame
+ ;; When we reset the face based on its spec, then it is unmodified
+ ;; as far as Custom is concerned.
+ (put (or (get face 'face-alias) face) 'face-modified nil)
+;;; ;; Clear all the new-frame defaults 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))))
+ ;; Set each frame according to the rules implied by SPEC.
+ (dolist (frame (frame-list))
+ (face-spec-set face spec frame))))
(defun face-attr-match-p (face attrs &optional frame)
(defun color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.
-The value is a list of integer RGB values--\(RED GREEN BLUE\).
-These values appear to range from 0 65535; white is \(65535 65535 65535\).
+The value is a list of integer RGB values--(RED GREEN BLUE).
+These values appear to range from 0 to 65280 or 65535, depending
+on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\).
If FRAME is omitted or nil, use the selected frame.
If FRAME cannot display COLOR, the value is nil.
If COLOR is the symbol `unspecified' or one of the strings
(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.
+
+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.
+
+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.
+
+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."
+ (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))
+
+(defun face-at-point ()
+ "Return the face of the character after point.
+If it has more than one face, return the first one.
+Return nil if it has no specified face."
+ (let* ((faceprop (or (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face)
+ 'default))
+ (face (cond ((symbolp faceprop) faceprop)
+ ;; List of faces (don't treat an attribute spec).
+ ;; Just use the first face.
+ ((and (consp faceprop) (not (keywordp (car faceprop)))
+ (not (memq (car faceprop)
+ '(foreground-color background-color))))
+ (car faceprop))
+ (t nil)))) ; Invalid face value.
+ (if (facep face) face nil)))
+
+(defun foreground-color-at-point ()
+ "Return the foreground color of the character after point."
+ ;; `face-at-point' alone is not sufficient. It only gets named faces.
+ ;; Need also pick up any face properties that are not associated with named faces.
+ (let ((face (or (face-at-point)
+ (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face))))
+ (cond ((and face (symbolp face))
+ (let ((value (face-foreground face nil 'default)))
+ (if (member value '("unspecified-fg" "unspecified-bg"))
+ nil
+ value)))
+ ((consp face)
+ (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face)))
+ ((memq ':foreground face) (cadr (memq ':foreground face)))))
+ (t nil)))) ; Invalid face value.
+
+(defun background-color-at-point ()
+ "Return the background color of the character after point."
+ ;; `face-at-point' alone is not sufficient. It only gets named faces.
+ ;; Need also pick up any face properties that are not associated with named faces.
+ (let ((face (or (face-at-point)
+ (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face))))
+ (cond ((and face (symbolp face))
+ (let ((value (face-background face nil 'default)))
+ (if (member value '("unspecified-fg" "unspecified-bg"))
+ nil
+ value)))
+ ((consp face)
+ (cond ((memq 'background-color face) (cdr (memq 'background-color face)))
+ ((memq ':background face) (cadr (memq ':background face)))))
+ (t nil)))) ; Invalid face value.
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Background mode.
tty-type))
'dark
'light))
- ((>= (apply '+ (x-color-values bg-color frame))
+ ((>= (apply '+ (color-values bg-color frame))
;; Just looking at the screen, colors whose
;; values add up to .6 of the white total
;; still look dark to me.
- (* (apply '+ (x-color-values "white" frame)) .6))
+ (* (apply '+ (color-values "white" frame)) .6))
'light)
(t 'dark)))
(display-type
(cond ((null (window-system frame))
(if (tty-display-color-p frame) 'color 'mono))
- ((x-display-color-p frame)
+ ((display-color-p frame)
'color)
((x-display-grayscale-p frame)
'grayscale)
(x-handle-reverse-video frame parameters)
(frame-set-background-mode frame)
(face-set-after-frame-default frame)
- ;; Arrange for the kill and yank functions to set and check the clipboard.
- (modify-frame-parameters
- frame '((interprogram-cut-function . x-select-text)))
- (modify-frame-parameters
- frame '((interprogram-paste-function . x-cut-buffer-or-selection-value)))
;; Make sure the tool-bar is ready to be enabled. The
;; `tool-bar-lines' frame parameter will not take effect
;; without this call.
(face-attribute 'default :weight t))
(set-face-attribute 'default frame :width
(face-attribute 'default :width t))))
- (dolist (face (face-list))
- ;; Don't let frame creation fail because of an invalid face spec.
- (condition-case ()
- (when (not (equal face 'default))
- (face-spec-set face (face-user-default-spec face) frame)
- (internal-merge-in-global-face face frame)
- (when (and (memq (window-system frame) '(x w32 mac))
- (or (not (boundp 'inhibit-default-face-x-resources))
- (not (eq face 'default))))
- (make-face-x-resource-internal face frame)))
- (error nil)))
- ;; Initialize attributes from frame parameters.
- (let ((params '((foreground-color default :foreground)
- (background-color default :background)
- (border-color border :background)
- (cursor-color cursor :background)
- (scroll-bar-foreground scroll-bar :foreground)
- (scroll-bar-background scroll-bar :background)
- (mouse-color mouse :background))))
- (dolist (param params)
- (let ((frame-param (frame-parameter frame (nth 0 param)))
- (face (nth 1 param))
- (attr (nth 2 param)))
- (when (and frame-param
- ;; Don't override face attributes explicitly
- ;; specified for new frames.
- (eq (face-attribute face attr t) 'unspecified))
- (set-face-attribute face frame attr frame-param))))))
-
+ ;; Find attributes that should be initialized from frame parameters.
+ (let ((face-params '((foreground-color default :foreground)
+ (background-color default :background)
+ (border-color border :background)
+ (cursor-color cursor :background)
+ (scroll-bar-foreground scroll-bar :foreground)
+ (scroll-bar-background scroll-bar :background)
+ (mouse-color mouse :background)))
+ apply-params)
+ (dolist (param face-params)
+ (let* ((value (frame-parameter frame (nth 0 param)))
+ (face (nth 1 param))
+ (attr (nth 2 param))
+ (default-value (face-attribute face attr t)))
+ ;; Compile a list of face attributes to set, but don't set
+ ;; them yet. The call to make-face-x-resource-internal,
+ ;; below, can change frame parameters, and the final set of
+ ;; frame parameters should be the ones acquired at this step.
+ (if (eq default-value 'unspecified)
+ ;; The face spec does not specify a new-frame value for
+ ;; this attribute. Check if the existing frame parameter
+ ;; specifies it.
+ (if value
+ (push (list face frame attr value) apply-params))
+ ;; The face spec specifies a value for this attribute, to be
+ ;; applied to the face on all new frames.
+ (push (list face frame attr default-value) apply-params))))
+ ;; Initialize faces from face specs and X resources. The
+ ;; condition-case prevents invalid specs from causing frame
+ ;; creation to fail.
+ (dolist (face (delq 'default (face-list)))
+ (condition-case ()
+ (progn
+ (face-spec-set face (face-user-default-spec face) frame)
+ (if (memq (window-system frame) '(x w32 mac))
+ (make-face-x-resource-internal face frame))
+ (internal-merge-in-global-face face frame))
+ (error nil)))
+ ;; Apply the attributes specified by frame parameters. This
+ ;; rewrites parameters changed by make-face-x-resource-internal
+ (dolist (param apply-params)
+ (apply 'set-face-attribute param))))
(defun tty-handle-reverse-video (frame parameters)
"Handle the reverse-video frame parameter for terminal frames."
(with-selected-frame frame
(tty-handle-reverse-video frame (frame-parameters frame))
- ;; Make sure the kill and yank functions do not touch the X clipboard.
- (modify-frame-parameters frame '((interprogram-cut-function . nil)))
- (modify-frame-parameters frame '((interprogram-paste-function . nil)))
-
- (set-locale-environment nil frame)
- (tty-run-terminal-initialization frame)
+ (unless (terminal-parameter frame 'terminal-initted)
+ (set-terminal-parameter frame 'terminal-initted t)
+ (set-locale-environment nil frame)
+ (tty-run-terminal-initialization frame))
(frame-set-background-mode frame)
(face-set-after-frame-default frame)
(setq success t))
;; Load library for our terminal type.
;; User init file can set term-file-prefix to nil to prevent this.
(with-selected-frame frame
- (unless (or (null term-file-prefix)
- ;; Don't reinitialize the terminal each time a new
- ;; frame is opened on it.
- (terminal-parameter frame 'terminal-initted))
+ (unless (null term-file-prefix)
(let* (term-init-func)
;; First, load the terminal initialization file, if it is
;; available and it hasn't been loaded already.
:version "22.1"
:group 'basic-faces)
-(defface momentary
- '((t (:inherit mode-line)))
- "Face for momentarily displaying text in the current buffer."
- :version "22.1"
- :group 'basic-faces)
-
(defface minibuffer-prompt
'((((background dark)) :foreground "cyan")
;; Don't use blue because many users of the MS-DOS port customize
;; their foreground color to be blue.
(((type pc)) :foreground "magenta")
- (t :foreground "dark blue"))
+ (t :foreground "medium blue"))
"Face for minibuffer prompts.
By default, Emacs automatically adds this face to the value of
`minibuffer-prompt-properties', which is a list of text properties
HCoop / bpt / emacs.git / blobdiff