;;; faces.el --- Lisp faces
-;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000
;; Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;;; Code:
(eval-when-compile
- (require 'custom)
(require 'cl))
(require 'cus-face)
(set-default symbol value)
(internal-set-font-selection-order value)))
-
+;; This is defined originally in {w32,x}faces.c.
(defcustom face-font-family-alternatives
'(("courier" "fixed")
- ("helv" "helvetica" "fixed"))
+ ("helv" "helvetica" "arial" "fixed"))
"*Alist of alternative font family names.
Each element has the the form (FAMILY ALTERNATIVE1 ALTERNATIVE2 ...).
If fonts of family FAMILY can't be loaded, try ALTERNATIVE1, then
;; 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.
+;; private to the face implementation.
(defun internal-find-face (name &optional frame)
"Retrieve the face named NAME.
This function is defined for compatibility with Emacs 20.2. It
should not be used anymore."
(facep name))
+(make-obsolete 'internal-find-face 'facep "21.1")
(defun internal-get-face (name &optional frame)
should not be used anymore."
(or (internal-find-face name frame)
(check-face name)))
-
+(make-obsolete 'internal-get-face "See `facep' and `check-face'." "21.1")
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(:stipple
(".attributeStipple" . "Face.AttributeStipple")
(".attributeBackgroundPixmap" . "Face.AttributeBackgroundPixmap"))
- (:font (".attributeFont" . "Face.AttributeFont"))
(:bold (".attributeBold" . "Face.AttributeBold"))
(:italic (".attributeItalic" . "Face.AttributeItalic"))
(:font (".attributeFont" . "Face.AttributeFont")))
(defun set-face-documentation (face string)
"Set the documentation string for FACE to STRING."
- (put face 'face-documentation string))
+ ;; Perhaps the text should go in DOC.
+ (put face 'face-documentation (purecopy string)))
(defalias 'face-doc-string 'face-documentation)
`:inverse-video'
VALUE specifies whether characters in FACE should be displayed in
-inverse video. VALUE must be one of t or nil.
+inverse video. VALUE must be one of t or nil.
`:stipple'
For compatibility with Emacs 20, keywords `:bold' and `:italic' can
be used to specify that a bold or italic font should be used. VALUE
must be t or nil in that case. A value of `unspecified' is not allowed."
+ (setq args (purecopy args))
(cond ((null frame)
;; Change face on all frames.
(dolist (frame (frame-list))
(t
(while args
(internal-set-lisp-face-attribute face (car args)
- (car (cdr args)) frame)
+ (purecopy (cadr args))
+ frame)
(setq args (cdr (cdr args)))))))
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font weight."
- (interactive (list (read-face-name "Make which face bold: ")))
+ (interactive (list (read-face-name "Make which face bold ")))
(set-face-attribute face frame :weight 'bold))
"Make the font of FACE be non-bold, if possible.
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility."
- (interactive (list (read-face-name "Make which face non-bold: ")))
+ (interactive (list (read-face-name "Make which face non-bold ")))
(set-face-attribute face frame :weight 'normal))
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font slant."
- (interactive (list (read-face-name "Make which face italic: ")))
+ (interactive (list (read-face-name "Make which face italic ")))
(set-face-attribute face frame :slant 'italic))
(defun make-face-unitalic (face &optional frame noerror)
"Make the font of FACE be non-italic, if possible.
-FRAME nil or not specified means change face on all frames."
- (interactive (list (read-face-name "Make which face non-italic: ")))
+FRAME nil or not specified means change face on all frames.
+Argument NOERROR is ignored and retained for compatibility."
+ (interactive (list (read-face-name "Make which face non-italic ")))
(set-face-attribute face frame :slant 'normal))
(defun set-face-stipple (face stipple &optional frame)
"Change the stipple pixmap of face FACE to STIPPLE.
FRAME nil or not specified means change face on all frames.
-STIPPLE. should be a string, the name of a file of pixmap data.
+STIPPLE should be a string, the name of a file of pixmap data.
The directories listed in the `x-bitmap-file-path' variable are searched.
Alternatively, STIPPLE may be a list of the form (WIDTH HEIGHT DATA)
If FACE specifies neither foreground nor background color,
set its foreground and background to the background and foreground
of the default face. Value is FACE."
- (interactive (list (read-face-name "Invert face: ")))
+ (interactive (list (read-face-name "Invert face ")))
(let ((fg (face-attribute face :foreground frame))
(bg (face-attribute face :background frame)))
(if (or fg bg)
Value is a symbol naming a known face."
(let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x))
(face-list)))
+ (def (thing-at-point 'symbol))
face)
- (while (equal "" (setq face (completing-read prompt face-list nil t))))
+ (cond ((assoc def face-list)
+ (setq prompt (concat prompt "(default " def "): ")))
+ (t (setq def nil)
+ (setq prompt (concat prompt ": "))))
+ (while (equal "" (setq face (completing-read
+ prompt face-list nil t nil nil def))))
(intern face)))
(internal-lisp-face-attribute-values attribute))))
((:foreground :background)
(mapcar #'(lambda (c) (cons c c))
- (or (and window-system (x-defined-colors frame))
- (tty-defined-colors))))
+ (defined-colors frame)))
((:height)
'integerp)
(:stipple
name of the attribute for prompting. Value is the new attribute value."
(let ((new-value
(face-read-string face
- (if (eq default 'unspecified)
- 'unspecified
+ (if (memq default
+ '(unspecified
+ "unspecified-fg"
+ "unspecified-bg"))
+ default
(int-to-string default))
name
(list (cons "unspecified" 'unspecified)))))
- (if (eq new-value 'unspecified)
+ (if (memq new-value '(unspecified "unspecified-fg" "unspecified-bg"))
new-value
(string-to-int new-value))))
(cond ((listp valid)
(setq new-value
(face-read-string face old-value attribute-name valid))
+ ;; Terminal frames can support colors that don't appear
+ ;; explicitly in VALID, using color approximation code
+ ;; in tty-colors.el.
+ (if (and (memq attribute '(:foreground :background))
+ (not (memq window-system '(x w32 mac)))
+ (not (memq new-value
+ '(unspecified
+ "unspecified-fg"
+ "unspecified-bg"))))
+ (setq new-value (car (tty-color-desc new-value frame))))
(unless (eq new-value 'unspecified)
(setq new-value (cdr (assoc new-value valid)))))
((eq valid 'integerp)
"Read the name of a font for FACE on FRAME.
If optional argument FRAME Is nil or omitted, use the selected frame."
(let ((completion-ignore-case t))
- (completing-read "Set font attributes of face %s from font: "
- face (x-list-fonts "*" nil frame))))
+ (completing-read (format "Set font attributes of face %s from font: " face)
+ (mapcar 'list (x-list-fonts "*" nil frame)))))
(defun read-all-face-attributes (face &optional frame)
If optional argument FRAME is nil or omitted, modify the face used
for newly created frame, i.e. the global face."
(interactive)
- (let ((face (read-face-name "Modify face: ")))
+ (let ((face (read-face-name "Modify face ")))
(apply #'set-face-attribute face frame
(read-all-face-attributes face frame))))
Value is a list (FACE NEW-VALUE) where FACE is the face read
(a symbol), and NEW-VALUE is value read."
(cond ((eq attribute :font)
- (let* ((prompt (format "Set font-related attributes of face: "))
+ (let* ((prompt (format "Set font-related attributes of face "))
(face (read-face-name prompt))
(font (read-face-font face frame)))
(list face font)))
(t
(let* ((attribute-name (face-descriptive-attribute-name attribute))
- (prompt (format "Set %s of face: " attribute-name))
+ (prompt (format "Set %s of face " attribute-name))
(face (read-face-name prompt))
(new-value (read-face-attribute face attribute frame)))
(list face new-value)))))
(let ((faces (sort (face-list) #'string-lessp))
(face nil)
(frame (selected-frame))
- disp-frame window)
+ disp-frame window face-name)
(with-output-to-temp-buffer "*Faces*"
(save-excursion
(set-buffer standard-output)
(setq truncate-lines t)
+ (insert
+ (substitute-command-keys
+ (concat
+ "Use "
+ (if (display-mouse-p) "\\[help-follow-mouse] or ")
+ "\\[help-follow] on a face name to customize it\n"
+ "or on its sample text for a decription of the face.\n\n")))
+ (setq help-xref-stack nil)
(while faces
(setq face (car faces))
(setq faces (cdr faces))
- (insert (format "%25s " (face-name face)))
+ (setq face-name (symbol-name face))
+ (insert (format "%25s " face-name))
+ ;; Hyperlink to a customization buffer for the face. Using
+ ;; the help xref mechanism may not be the best way.
+ (save-excursion
+ (save-match-data
+ (search-backward face-name)
+ (help-xref-button 0 (lambda (f)
+ (if help-xref-stack
+ (pop help-xref-stack))
+ (customize-face f))
+ face-name
+ "mouse-2: customize this face")))
(let ((beg (point)))
(insert list-faces-sample-text)
+ ;; Hyperlink to a help buffer for the face.
+ (save-excursion
+ (save-match-data
+ (search-backward list-faces-sample-text)
+ (help-xref-button 0 #'describe-face face
+ "mouse-2: describe this face")))
(insert "\n")
(put-text-property beg (1- (point)) 'face face)
;; If the sample text has multiple lines, line up all of them.
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: ")))
+ (interactive (list (read-face-name "Describe face")))
(let* ((attrs '((:family . "Family")
(:width . "Width")
(:height . "Height")
(:strike-through . "Strike-through")
(:box . "Box")
(:inverse-video . "Inverse")
- (:stipple . "Stipple")))
+ (:stipple . "Stipple")
+ (:font . "Font or fontset")))
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x)))
attrs))))
(with-output-to-temp-buffer "*Help*"
(cdr a) ": " (format "%s" attr) "\n")))
(insert "\nDocumentation:\n\n"
(or (face-documentation face)
- "not documented as a face.")))
- (print-help-return-message))))
-
-
-
+ "not documented as a face."))
+ (let ((customize-label "customize"))
+ (terpri)
+ (terpri)
+ (princ (concat "You can " customize-label " this face."))
+ (with-current-buffer "*Help*"
+ (save-excursion
+ (re-search-backward
+ (concat "\\(" customize-label "\\)") nil t)
+ (help-xref-button 1 #'customize-face face
+ "mouse-2, RET: customize face")))))
+ (print-help-return-message)
+ (with-current-buffer "*Help*"
+ (help-setup-xref (list #'describe-face face) (interactive-p))
+ (buffer-string)))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Face specifications (defface).
((eq req 'background)
(memq (frame-parameter frame 'background-mode)
options))
- (t (error "Unknown req `%S' with options `%S'"
+ (t (error "Unknown req `%S' with options `%S'"
req options)))))
match))
;; 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))))
- (setq params (cons attribute (cons value params))))
+ (:italic (setq attribute :slant value (if value 'italic 'normal)))
+ (t (unless (assq attribute face-x-resources)
+ (setq attribute nil))))
+ (when attribute
+ (setq params (cons attribute (cons value params)))))
(setq attrs (cdr (cdr attrs))))
(face-spec-reset-face face frame)
(apply #'set-face-attribute face frame params)))
(face-attr-match-p face (face-spec-choose spec frame) frame))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Frame-type independent color support.
+;;; We keep the old x-* names as aliases for back-compatibility.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun defined-colors (&optional frame)
+ "Return a list of colors supported for a particular frame.
+The argument FRAME specifies which frame to try.
+The value may be different for frames on different display types.
+If FRAME doesn't support colors, the value is nil."
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-defined-colors frame)
+ (mapcar 'car (tty-color-alist frame))))
+(defalias 'x-defined-colors 'defined-colors)
+
+(defun color-defined-p (color &optional frame)
+ "Return non-nil if color COLOR is supported on frame FRAME.
+If FRAME is omitted or nil, use the selected frame.
+If COLOR is the symbol `unspecified' or one of the strings
+\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
+ (if (memq color '(unspecified "unspecified-bg" "unspecified-fg"))
+ nil
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-color-defined-p color frame)
+ (numberp (tty-color-translate color frame)))))
+(defalias 'x-color-defined-p 'color-defined-p)
+
+(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 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
+\"unspecified-fg\" or \"unspecified-bg\", the value is nil."
+ (if (memq color '(unspecified "unspecified-fg" "unspecified-bg"))
+ nil
+ (if (memq (framep (or frame (selected-frame))) '(x w32))
+ (xw-color-values color frame)
+ (tty-color-values color frame))))
+(defalias 'x-color-values 'color-values)
+
+(defun display-color-p (&optional display)
+ "Return t if DISPLAY supports color.
+The optional argument DISPLAY specifies which display to ask about.
+DISPLAY should be either a frame or a display name (a string).
+If omitted or nil, that stands for the selected frame's display."
+ (if (memq (framep-on-display display) '(x w32))
+ (xw-display-color-p display)
+ (tty-display-color-p display)))
+(defalias 'x-display-color-p 'display-color-p)
+
+(defun display-grayscale-p (&optional display)
+ "Return non-nil if frames on DISPLAY can display shades of gray."
+ (let ((frame-type (framep-on-display display)))
+ (cond
+ ((memq frame-type '(x w32 mac))
+ (x-display-grayscale-p display))
+ (t
+ (> (tty-color-gray-shades display) 2)))))
+
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Background mode.
examine the brightness for you."
:group 'faces
:set #'(lambda (var value)
- (set var value)
+ (set-default var value)
(mapcar 'frame-set-background-mode (frame-list)))
:initialize 'custom-initialize-changed
- :type '(choice (choice-item dark)
+ :type '(choice (choice-item dark)
(choice-item light)
(choice-item :tag "default" nil)))
'dark)
(t 'light)))
(display-type (cond ((null window-system)
- (if (tty-display-color-p) 'color 'mono))
+ (if (tty-display-color-p frame) 'color 'mono))
((x-display-color-p frame)
'color)
((x-display-grayscale-p frame)
;; Update a frame's faces when we change its default font.
-(defun frame-update-faces (frame)
- nil)
-
+(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.
-(defun frame-update-face-colors (frame)
- (frame-set-background-mode frame))
-
+(defalias 'frame-update-face-colors 'frame-set-background-mode)
+(make-obsolete 'frame-update-face-colors 'frame-set-background-mode "21.1")
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defface mode-line
'((((type x) (class color))
- (:box (:line-width 2 :style released-button) :background "grey75"))
+ (:box (:line-width 2 :style released-button)
+ :background "grey75" :foreground "black"))
+ (((type w32) (class color))
+ (:box (:line-width 2 :style released-button)
+ :background "grey75" :foreground "black"))
(t
(:inverse-video t)))
"Basic mode line face."
:version "21.1"
+ :group 'modeline
:group 'basic-faces)
;; Make `modeline' an alias for `mode-line', for compatibility.
(defface header-line
'((((type x) (class color))
- (:box (:line-width 2 :style released-button) :background "grey75"))
+ (:box (:line-width 2 :style released-button)
+ :background "grey75" :foreground "black"))
+ (((type w32) (class color))
+ (:box (:line-width 2 :style released-button)
+ :background "grey75" :foreground "black"))
(t
(:inverse-video t)))
"Basic header-line face."
(defface tool-bar
'((((type x) (class color))
- (:box (:line-width 1 :style released-button) :background "grey75"))
+ (:box (:line-width 1 :style released-button)
+ :background "grey75" :foreground "black"))
(((type x) (class mono))
- (:box (:line-width 1 :style released-button) :background "grey"))
+ (:box (:line-width 1 :style released-button)
+ :background "grey" :foreground "black"))
+ (((type w32) (class color))
+ (:box (:line-width 1 :style released-button)
+ :background "grey75" :foreground "black"))
(t
()))
"Basic tool-bar face."
(((class color) (background dark))
(:background "blue"))
(((class color) (background light))
- (:background "lightblue"))
+ (:background "light goldenrod yellow"))
(t (:background "gray")))
"Basic face for highlighting the region."
:group 'basic-faces)
(defface fringe
- '((((class color))
- (:background "grey95"))
- (t
- (:background "gray")))
+ '((((class color) (background light))
+ (:background "grey95"))
+ (((class color) (background dark))
+ (:background "grey10"))
+ (t
+ (:background "gray")))
"Basic face for the fringes to the left and right of windows under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(defface scroll-bar '()
"Basic face for the scroll bar colors under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(t (:inverse-video t)))
"Basic menu face."
:version "21.1"
+ :group 'menu
:group 'basic-faces)
(defface border '()
"Basic face for the frame border under X."
:version "21.1"
+ :group 'frames
:group 'basic-faces)
(defface cursor '()
"Basic face for the cursor color under X."
:version "21.1"
+ :group 'cursor
:group 'basic-faces)
(defface mouse '()
"Basic face for the mouse color under X."
:version "21.1"
+ :group 'mouse
:group 'basic-faces)
'((((type tty) (class color))
(:background "cyan"))
(((class color) (background light))
- (:background "darkyellow"))
+ (:background "yellow"))
(((class color) (background dark))
(:background "yellow"))
(t (:inverse-video t)))
:group 'basic-faces)
-(defface fixed-pitch '((t (:family "courier*")))
+(defface fixed-pitch '((t (:family "courier")))
"The basic fixed-pitch face."
:group 'basic-faces)
-(defface variable-pitch '((t (:family "helv*")))
+(defface variable-pitch '((t (:family "helv")))
"The basic variable-pitch face."
:group 'basic-faces)
(t (:inverse-video t)))
"Basic face for highlighting trailing whitespace."
:version "21.1"
+ :group 'font-lock ; like `show-trailing-whitespace'
:group 'basic-faces)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is here for compatibilty with Emacs 20.2. For example,
-;; international/fontset.el uses these functions to manipulate font
-;; names. The following functions are not used in the face
-;; implementation itself.
+;; international/fontset.el uses x-resolve-font-name. The following
+;; functions are not used in the face implementation itself.
(defvar x-font-regexp nil)
(defvar x-font-regexp-head nil)
"\\([-*?]\\|\\'\\)"))
(setq x-font-regexp-slant (concat - slant -))
(setq x-font-regexp-weight (concat - weight -))
- nil)
+ nil)
(defun x-resolve-font-name (pattern &optional face frame)
"Return a font name matching PATTERN.
-All wildcards in PATTERN become substantiated.
+All wildcards in PATTERN are instantiated.
If PATTERN is nil, return the name of the frame's base font, which never
contains wildcards.
Given optional arguments FACE and FRAME, return a font which is
((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))
((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")
(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."
(x-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."
(x-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."
(x-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."
(x-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."
(x-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."
(x-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 (x-make-font-bold font))
(x-make-font-italic font)))
-
+(make-obsolete 'x-make-font-bold-italic 'make-face-bold-italic "21.1")
(provide 'faces)
-;;; end of faces.el
+;;; faces.el ends here