;;; faces.el --- Lisp interface to the c "face" structure
-;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
(put 'set-face-font 'byte-optimizer nil)
(put 'set-face-foreground 'byte-optimizer nil)
(put 'set-face-background 'byte-optimizer nil)
- (put 'set-stipple 'byte-optimizer nil)
+ (put 'set-face-stipple 'byte-optimizer nil)
(put 'set-face-underline-p 'byte-optimizer nil))
\f
;;;; Functions for manipulating face vectors.
If FRAME is omitted or nil, use the selected frame."
(aref (internal-get-face face frame) 7))
+(defun face-bold-p (face &optional frame)
+ "Return non-nil if the font of FACE is bold.
+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).
+ The font default for a face is either nil, or a list
+ of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+ (let ((font (face-font face frame)))
+ (if (stringp font)
+ (not (eq font (x-make-font-unbold font)))
+ (memq 'bold font))))
+
+(defun face-italic-p (face &optional frame)
+ "Return non-nil if the font of FACE is italic.
+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).
+ The font default for a face is either nil, or a list
+ of the form (bold), (italic) or (bold italic).
+If FRAME is omitted or nil, use the selected frame."
+ (let ((font (face-font face frame)))
+ (if (stringp font)
+ (not (eq font (x-make-font-unitalic font)))
+ (memq 'italic font))))
+
+(defun face-doc-string (face)
+ "Get the documentation string for FACE."
+ (get face 'face-documentation))
\f
;;; Mutators.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
(interactive (internal-face-interactive "font"))
- (if (stringp font) (setq font (x-resolve-font-name font 'default frame)))
+ (if (stringp font)
+ (setq font (or (query-fontset font)
+ (x-resolve-font-name font 'default frame))))
(internal-set-face-1 face 'font font 3 frame))
(defun set-face-foreground (face color &optional frame)
(interactive (internal-face-interactive "foreground"))
(internal-set-face-1 face 'foreground color 4 frame))
+(defvar face-default-stipple "gray3"
+ "Default stipple pattern used on monochrome displays.
+This stipple pattern is used on monochrome displays
+instead of shades of gray for a face background color.
+See `set-face-stipple' for possible values for this variable.")
+
+(defun face-color-gray-p (color &optional frame)
+ "Return t if COLOR is a shade of gray (or white or black).
+FRAME specifies the frame and thus the display for interpreting COLOR."
+ (let* ((values (x-color-values color frame))
+ (r (nth 0 values))
+ (g (nth 1 values))
+ (b (nth 2 values)))
+ (and values
+ (< (abs (- r g)) (/ (max 1 (abs r) (abs g)) 20))
+ (< (abs (- g b)) (/ (max 1 (abs g) (abs b)) 20))
+ (< (abs (- b r)) (/ (max 1 (abs b) (abs r)) 20)))))
+
(defun set-face-background (face color &optional frame)
"Change the background color of face FACE to COLOR (a string).
If the optional FRAME argument is provided, change only
(interactive (internal-face-interactive "background"))
;; For a specific frame, use gray stipple instead of gray color
;; if the display does not support a gray color.
- (if (and frame (not (eq frame t))
- (member color '("gray" "gray1" "gray3"))
- (not (x-display-color-p frame))
- (not (x-display-grayscale-p frame)))
- (set-face-stipple face color frame)
- (internal-set-face-1 face 'background color 5 frame)))
-
-(defun set-face-stipple (face name &optional frame)
+ (if (and frame (not (eq frame t)) color
+ ;; Check for support for foreground, not for background!
+ ;; face-color-supported-p is smart enough to know
+ ;; that grays are "supported" as background
+ ;; because we are supposed to use stipple for them!
+ (not (face-color-supported-p frame color nil)))
+ (set-face-stipple face face-default-stipple frame)
+ (if (null frame)
+ (let ((frames (frame-list)))
+ (while frames
+ (set-face-background (face-name face) color (car frames))
+ (setq frames (cdr frames)))
+ (set-face-background face color t)
+ color)
+ (internal-set-face-1 face 'background color 5 frame))))
+
+(defun set-face-stipple (face pixmap &optional frame)
"Change the stipple pixmap of face FACE to PIXMAP.
PIXMAP should be a string, the name of a file of pixmap data.
The directories listed in the `x-bitmap-file-path' variable are searched.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
- (interactive (internal-face-interactive "stipple"))
- (internal-set-face-1 face 'background-pixmap name 6 frame))
+ (interactive (internal-face-interactive-stipple "stipple"))
+ (internal-set-face-1 face 'background-pixmap pixmap 6 frame))
(defalias 'set-face-background-pixmap 'set-face-stipple)
in that frame; otherwise change each frame."
(interactive (internal-face-interactive "underline-p" "underlined"))
(internal-set-face-1 face 'underline underline-p 7 frame))
+
+(defun set-face-bold-p (face bold-p &optional frame)
+ "Specify whether face FACE is bold. (Yes if BOLD-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (cond ((eq bold-p nil) (make-face-unbold face frame t))
+ (t (make-face-bold face frame t))))
+
+(defun set-face-italic-p (face italic-p &optional frame)
+ "Specify whether face FACE is italic. (Yes if ITALIC-P is non-nil.)
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame."
+ (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+ (t (make-face-italic face frame t))))
+
+(defun set-face-doc-string (face string)
+ "Set the documentation string for FACE to STRING."
+ (put face 'face-documentation string))
\f
(defun modify-face-read-string (face default name alist)
(let ((value
(t value))))
(defun modify-face (face foreground background stipple
- bold-p italic-p underline-p)
+ bold-p italic-p underline-p &optional frame)
"Change the display attributes for face FACE.
-FOREGROUND and BACKGROUND should be color strings or nil.
-STIPPLE should be a stipple pattern name or nil.
+If the optional FRAME argument is provided, change only
+in that frame; otherwise change each frame.
+
+FOREGROUND and BACKGROUND should be a colour name string (or list of strings to
+try) or nil. STIPPLE should be a stipple pattern name string or nil.
+If nil, means do not change the display attribute corresponding to that arg.
+
BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
-in italic, and underlined, respectively. (Yes if non-nil.)
-If called interactively, prompts for a face and face attributes."
+in italic, and underlined, respectively. If neither nil or t, means do not
+change the display attribute corresponding to that arg.
+
+If called interactively, prompts for a face name and face attributes."
(interactive
(let* ((completion-ignore-case t)
- (face (symbol-name (read-face-name "Modify face: ")))
- (colors (mapcar 'list x-colors))
- (stipples (mapcar 'list
- (apply 'nconc
- (mapcar 'directory-files
- x-bitmap-file-path))))
- (foreground (modify-face-read-string
- face (face-foreground (intern face))
- "foreground" colors))
- (background (modify-face-read-string
- face (face-background (intern face))
- "background" colors))
- (stipple (modify-face-read-string
- face (face-stipple (intern face))
- "stipple" stipples))
- (bold-p (y-or-n-p (concat "Set face " face " bold ")))
- (italic-p (y-or-n-p (concat "Set face " face " italic ")))
- (underline-p (y-or-n-p (concat "Set face " face " underline "))))
+ (face (symbol-name (read-face-name "Modify face: ")))
+ (colors (mapcar 'list x-colors))
+ (stipples (mapcar 'list (apply 'nconc
+ (mapcar 'directory-files
+ x-bitmap-file-path))))
+ (foreground (modify-face-read-string
+ face (face-foreground (intern face))
+ "foreground" colors))
+ (background (modify-face-read-string
+ face (face-background (intern face))
+ "background" colors))
+ ;; If the stipple value is a list (WIDTH HEIGHT DATA),
+ ;; represent that as a string by printing it out.
+ (old-stipple-string
+ (if (stringp (face-stipple (intern face)))
+ (face-stipple (intern face))
+ (if (face-stipple (intern face))
+ (prin1-to-string (face-stipple (intern face))))))
+ (new-stipple-string
+ (modify-face-read-string
+ face old-stipple-string
+ "stipple" stipples))
+ ;; Convert the stipple value text we read
+ ;; back to a list if it looks like one.
+ ;; This makes the assumption that a pixmap file name
+ ;; won't start with an open-paren.
+ (stipple
+ (and new-stipple-string
+ (if (string-match "^(" new-stipple-string)
+ (read new-stipple-string)
+ new-stipple-string)))
+ (bold-p (y-or-n-p (concat "Should face " face " be bold ")))
+ (italic-p (y-or-n-p (concat "Should face " face " be italic ")))
+ (underline-p (y-or-n-p (concat "Should face " face " be underlined ")))
+ (all-frames-p (y-or-n-p (concat "Modify face " face " in all frames "))))
(message "Face %s: %s" face
(mapconcat 'identity
(delq nil
(list (and foreground (concat (downcase foreground) " foreground"))
(and background (concat (downcase background) " background"))
- (and stipple (concat (downcase stipple) " stipple"))
+ (and stipple (concat (downcase new-stipple-string) " stipple"))
(and bold-p "bold") (and italic-p "italic")
(and underline-p "underline"))) ", "))
(list (intern face) foreground background stipple
- bold-p italic-p underline-p)))
- (condition-case nil (set-face-foreground face foreground) (error nil))
- (condition-case nil (set-face-background face background) (error nil))
- (condition-case nil (set-face-stipple face stipple) (error nil))
- (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
- (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t)
- (set-face-underline-p face underline-p)
+ bold-p italic-p underline-p
+ (if all-frames-p nil (selected-frame)))))
+ (condition-case nil
+ (face-try-color-list 'set-face-foreground face foreground frame)
+ (error nil))
+ (condition-case nil
+ (face-try-color-list 'set-face-background face background frame)
+ (error nil))
+ (condition-case nil
+ (set-face-stipple face stipple frame)
+ (error nil))
+ (cond ((eq bold-p nil) (make-face-unbold face frame t))
+ ((eq bold-p t) (make-face-bold face frame t)))
+ (cond ((eq italic-p nil) (make-face-unitalic face frame t))
+ ((eq italic-p t) (make-face-italic face frame t)))
+ (if (memq underline-p '(nil t))
+ (set-face-underline-p face underline-p frame))
(and (interactive-p) (redraw-display)))
\f
;;;; Associating face names (symbols) with their face vectors.
default))))
(list face (if (equal value "") nil value))))
-
-
-(defun make-face (name)
+(defun internal-face-interactive-stipple (what)
+ (let* ((fn (intern (concat "face-" what)))
+ (prompt (concat "Set " what " of face"))
+ (face (read-face-name (concat prompt ": ")))
+ (default (if (fboundp fn)
+ (or (funcall fn face (selected-frame))
+ (funcall fn 'default (selected-frame)))))
+ ;; If the stipple value is a list (WIDTH HEIGHT DATA),
+ ;; represent that as a string by printing it out.
+ (old-stipple-string
+ (if (stringp (face-stipple face))
+ (face-stipple face)
+ (if (null (face-stipple face))
+ nil
+ (prin1-to-string (face-stipple face)))))
+ (new-stipple-string
+ (read-string
+ (concat prompt " " (symbol-name face) " to: ")
+ old-stipple-string))
+ ;; Convert the stipple value text we read
+ ;; back to a list if it looks like one.
+ ;; This makes the assumption that a pixmap file name
+ ;; won't start with an open-paren.
+ (stipple
+ (if (string-match "^(" new-stipple-string)
+ (read new-stipple-string)
+ new-stipple-string)))
+ (list face (if (equal stipple "") nil stipple))))
+
+(defun make-face (name &optional no-resources)
"Define a new FACE on all frames.
You can modify the font, color, etc of this face with the set-face- functions.
+If NO-RESOURCES is non-nil, then we ignore X resources
+and always make a face whose attributes are all nil.
+
If the face already exists, it is unmodified."
(interactive "SMake face: ")
(or (internal-find-face name)
(frame-face-alist (car frames))))
(setq frames (cdr frames)))
(setq global-face-data (cons (cons name face) global-face-data)))
- ;; when making a face after frames already exist
- (if (eq window-system 'x)
- (make-face-x-resource-internal face))
- ;; add to menu
+ ;; When making a face after frames already exist
+ (or no-resources
+ (if (memq window-system '(x w32))
+ (make-face-x-resource-internal face)))
+ ;; Add to menu of faces.
(if (fboundp 'facemenu-add-new-face)
(facemenu-add-new-face name))
face))
name)
+(defun make-empty-face (face)
+ "Define a new FACE on all frames, which initially reflects the defaults.
+You can modify the font, color, etc of this face with the set-face- functions.
+If the face already exists, it is unmodified."
+ (interactive "SMake empty face: ")
+ (make-face face t))
+
;; Fill in a face by default based on X resources, for all existing frames.
;; This has to be done when a new face is made.
(defun make-face-x-resource-internal (face &optional frame set-anyway)
(cond ((null frame)
(let ((frames (frame-list)))
(while frames
- (if (eq (framep (car frames)) 'x)
+ (if (memq (framep (car frames)) '(x w32))
(make-face-x-resource-internal (face-name face)
(car frames) set-anyway))
(setq frames (cdr frames)))))
)
(if fn
(condition-case ()
- (set-face-font face fn frame)
- (error (message "font `%s' not found for face `%s'" fn name))))
+ (cond ((string= fn "italic")
+ (make-face-italic face))
+ ((string= fn "bold")
+ (make-face-bold face))
+ ((string= fn "bold-italic")
+ (make-face-bold-italic face))
+ (t
+ (set-face-font face fn frame)))
+ (error
+ (if (member fn '("italic" "bold" "bold-italic"))
+ (message "no %s version found for face `%s'" fn name)
+ (message "font `%s' not found for face `%s'" fn name)))))
(if fg
(condition-case ()
(set-face-foreground face fg frame)
(or (equal (face-background default frame)
(face-background face frame))
(null (face-background face frame)))
- (or (equal (face-font default frame) (face-font face frame))
- (null (face-font face frame)))
+ (or (null (face-font face frame))
+ (equal (face-font face frame)
+ (or (face-font default frame)
+ (downcase
+ (cdr (assq 'font (frame-parameters frame)))))))
(or (equal (face-stipple default frame)
(face-stipple face frame))
(null (face-stipple face frame)))
(progn
(set-face-foreground face bg frame)
(set-face-background face fg frame))
- (set-face-foreground face (or (face-background 'default frame)
- (cdr (assq 'background-color (frame-parameters frame))))
- frame)
- (set-face-background face (or (face-foreground 'default frame)
- (cdr (assq 'foreground-color (frame-parameters frame))))
- frame)))
+ (let* ((frame-bg (cdr (assq 'background-color (frame-parameters frame))))
+ (default-bg (or (face-background 'default frame)
+ frame-bg))
+ (frame-fg (cdr (assq 'foreground-color (frame-parameters frame))))
+ (default-fg (or (face-foreground 'default frame)
+ frame-fg)))
+ (set-face-foreground face default-bg frame)
+ (set-face-background face default-fg frame))))
face)
\f
;; Manipulating font names.
-(defconst x-font-regexp nil)
-(defconst x-font-regexp-head nil)
-(defconst x-font-regexp-weight nil)
-(defconst x-font-regexp-slant nil)
+(defvar x-font-regexp nil)
+(defvar x-font-regexp-head nil)
+(defvar x-font-regexp-weight nil)
+(defvar x-font-regexp-slant nil)
+
+(defconst x-font-regexp-weight-subnum 1)
+(defconst x-font-regexp-slant-subnum 2)
+(defconst x-font-regexp-swidth-subnum 3)
+(defconst x-font-regexp-adstyle-subnum 4)
;;; Regexps matching font names in "Host Portable Character Representation."
;;;
; (swidth "\\(\\*\\|normal\\|semicondensed\\|\\)") ; 3
(swidth "\\([^-]*\\)") ; 3
; (adstyle "\\(\\*\\|sans\\|\\)") ; 4
- (adstyle "[^-]*") ; 4
+ (adstyle "\\([^-]*\\)") ; 4
(pixelsize "[0-9]+")
(pointsize "[0-9][0-9]+")
(resx "[0-9][0-9]+")
(setq x-font-regexp
(concat "\\`\\*?[-?*]"
foundry - family - weight\? - slant\? - swidth - adstyle -
- pixelsize - pointsize - resx - resy - spacing - registry -
- encoding "[-?*]\\*?\\'"
+ pixelsize - pointsize - resx - resy - spacing - avgwidth -
+ registry - encoding "\\*?\\'"
))
(setq x-font-regexp-head
(concat "\\`[-?*]" foundry - family - weight\? - slant\?
(setq frame nil))
(if pattern
;; Note that x-list-fonts has code to handle a face with nil as its font.
- (let ((fonts (x-list-fonts pattern face frame)))
+ (let ((fonts (x-list-fonts pattern face frame 1)))
(or fonts
(if face
(if (string-match "\\*" pattern)
(cdr (assq 'font (frame-parameters (selected-frame))))))
(defun x-frob-font-weight (font which)
- (if (or (string-match x-font-regexp font)
- (string-match x-font-regexp-head font)
- (string-match x-font-regexp-weight font))
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1)))
- nil))
+ (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)))))))
(defun x-frob-font-slant (font which)
- (cond ((or (string-match x-font-regexp font)
- (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))))
- (t nil)))
-
+ (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)))))))
(defun x-make-font-bold (font)
"Given an X font specification, make a bold version of it.
(set-face-font face (if (memq 'italic (face-font face t))
'(bold italic) '(bold))
t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face bold in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-bold-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No bold version of %S" font))))))
+ (or (and font (make-face-bold-internal face frame font))
+ ;; We failed to find a bold version of the font.
+ noerror
+ (error "No bold version of %S" font))))))
(defun make-face-bold-internal (face frame font)
(let (f2)
(set-face-font face (if (memq 'bold (face-font face t))
'(bold italic) '(italic))
t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face italic in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-italic-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No italic version of %S" font))))))
+ (or (and font (make-face-italic-internal face frame font))
+ ;; We failed to find an italic version of the font.
+ noerror
+ (error "No italic version of %S" font))))))
(defun make-face-italic-internal (face frame font)
(let (f2)
(interactive (list (read-face-name "Make which face bold-italic: ")))
(if (and (eq frame t) (listp (face-font face t)))
(set-face-font face '(bold italic) t)
- (let ((ofont (face-font face frame))
- font)
+ (let (font)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face bold-italic in global-face-data.
(setq font (or font
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
- (and font (make-face-bold-italic-internal face frame font)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No bold italic version of %S" font))))))
+ (or (and font (make-face-bold-italic-internal face frame font))
+ ;; We failed to find a bold italic version.
+ noerror
+ (error "No bold italic version of %S" font))))))
(defun make-face-bold-italic-internal (face frame font)
(let (f2 f3)
(set-face-font face (if (memq 'italic (face-font face t))
'(italic) nil)
t)
- (let ((ofont (face-font face frame))
- font font1)
+ (let (font font1)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face unbold in global-face-data.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (and font1 (x-make-font-unbold font1)))
- (if font (internal-try-face-font face font frame)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No unbold version of %S" font1))))))
+ (or (if font (internal-try-face-font face font frame))
+ noerror
+ (error "No unbold version of %S" font1))))))
(defun make-face-unitalic (face &optional frame noerror)
"Make the font of the given face be non-italic, if possible.
(set-face-font face (if (memq 'bold (face-font face t))
'(bold) nil)
t)
- (let ((ofont (face-font face frame))
- font font1)
+ (let (font font1)
(if (null frame)
(let ((frames (frame-list)))
;; Make this face unitalic in global-face-data.
(face-font 'default frame)
(cdr (assq 'font (frame-parameters frame)))))
(setq font (and font1 (x-make-font-unitalic font1)))
- (if font (internal-try-face-font face font frame)))
- (or (not (equal ofont (face-font face)))
- (and (not noerror)
- (error "No unitalic version of %S" font1))))))
+ (or (if font (internal-try-face-font face font frame))
+ noerror
+ (error "No unitalic version of %S" font1))))))
\f
(defvar list-faces-sample-text
"abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"
(while faces
(copy-face (car faces) (car faces) frame disp-frame)
(setq faces (cdr faces)))))))
+
+(defun describe-face (face)
+ "Display the properties of face FACE."
+ (interactive (list (read-face-name "Describe face: ")))
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Properties of face `")
+ (princ (face-name face))
+ (princ "':") (terpri)
+ (princ "Foreground: ") (princ (face-foreground face)) (terpri)
+ (princ "Background: ") (princ (face-background face)) (terpri)
+ (princ " Font: ") (princ (face-font face)) (terpri)
+ (princ "Underlined: ") (princ (if (face-underline-p face) "yes" "no")) (terpri)
+ (princ " Stipple: ") (princ (or (face-stipple face) "none")) (terpri)
+ (terpri)
+ (princ "Documentation:") (terpri)
+ (let ((doc (face-doc-string face)))
+ (if doc
+ (princ doc)
+ (princ "not documented as a face.")))))
\f
;;; Make the standard faces.
;;; The C code knows the default and modeline faces as faces 0 and 1,
(face-fill-in face (cdr (car rest)) frame)))
(setq rest (cdr rest)))))
(setq frames (cdr frames)))))
-
+\f
+;;; Setting a face based on a SPEC.
+
+(defun face-spec-set (face spec &optional frame)
+ "Set FACE's face attributes according to the first matching entry in SPEC.
+If optional FRAME is non-nil, set it for that frame only.
+If it is nil, then apply SPEC to each frame individually.
+See `defface' for information about SPEC."
+ (let ((tail spec))
+ (while tail
+ (let* ((entry (car tail))
+ (display (nth 0 entry))
+ (attrs (nth 1 entry)))
+ (setq tail (cdr tail))
+ (modify-face face nil nil nil nil nil nil frame)
+ (when (face-spec-set-match-display display frame)
+ (face-spec-set-1 face frame attrs ':foreground 'set-face-foreground)
+ (face-spec-set-1 face frame attrs ':background 'set-face-background)
+ (face-spec-set-1 face frame attrs ':stipple 'set-face-stipple)
+ (face-spec-set-1 face frame attrs ':bold 'set-face-bold-p)
+ (face-spec-set-1 face frame attrs ':italic 'set-face-italic-p)
+ (face-spec-set-1 face frame attrs ':underline 'set-face-underline-p)
+ (setq tail nil)))))
+ (if (null frame)
+ (let ((frames (frame-list))
+ frame)
+ (while frames
+ (setq frame (car frames)
+ frames (cdr frames))
+ (face-spec-set face (or (get face 'saved-face)
+ (get face 'face-defface-spec))
+ frame)
+ (face-spec-set face spec frame)))))
+
+(defun face-spec-set-1 (face frame plist property function)
+ (while (and plist (not (eq (car plist) property)))
+ (setq plist (cdr (cdr plist))))
+ (if plist
+ (funcall function face (nth 1 plist) frame)))
+
+(defun face-spec-set-match-display (display frame)
+ "Non-nil iff DISPLAY matches FRAME.
+DISPLAY is part of a spec such as can be used in `defface'.
+If FRAME is nil, the current FRAME is used."
+ (let* ((conjuncts display)
+ conjunct req options
+ ;; t means we have succeeded against all
+ ;; the conjunts in DISPLAY that have been tested so far.
+ (match t))
+ (if (eq conjuncts t)
+ (setq conjuncts nil))
+ (while (and conjuncts match)
+ (setq conjunct (car conjuncts)
+ conjuncts (cdr conjuncts)
+ req (car conjunct)
+ options (cdr conjunct)
+ match (cond ((eq req 'type)
+ (memq window-system options))
+ ((eq req 'class)
+ (memq (frame-parameter frame 'display-type) options))
+ ((eq req 'background)
+ (memq (frame-parameter frame 'background-mode)
+ options))
+ (t
+ (error "Unknown req `%S' with options `%S'"
+ req options)))))
+ match))
\f
;; Like x-create-frame but also set up the faces.
(defun x-create-frame-with-faces (&optional parameters)
- (if (null global-face-data)
- (x-create-frame parameters)
- (let* ((visibility-spec (assq 'visibility parameters))
- (frame (x-create-frame (cons '(visibility . nil) parameters)))
- (faces (copy-alist global-face-data))
- success
- (rest faces))
- (unwind-protect
- (progn
- (set-frame-face-alist frame faces)
-
- (if (cdr (or (assq 'reverse parameters)
- (assq 'reverse default-frame-alist)
- (let ((resource (x-get-resource "reverseVideo"
- "ReverseVideo")))
- (if resource
- (cons nil (member (downcase resource)
- '("on" "true")))))))
- (let* ((params (frame-parameters frame))
- (bg (cdr (assq 'foreground-color params)))
- (fg (cdr (assq 'background-color params))))
- (modify-frame-parameters frame
- (list (cons 'foreground-color fg)
- (cons 'background-color bg)))
- (if (equal bg (cdr (assq 'border-color params)))
- (modify-frame-parameters frame
- (list (cons 'border-color fg))))
- (if (equal bg (cdr (assq 'mouse-color params)))
- (modify-frame-parameters frame
- (list (cons 'mouse-color fg))))
- (if (equal bg (cdr (assq 'cursor-color params)))
- (modify-frame-parameters frame
- (list (cons 'cursor-color fg))))))
- ;; Copy the vectors that represent the faces.
- ;; Also fill them in from X resources.
- (while rest
- (let ((global (cdr (car rest))))
- (setcdr (car rest) (vector 'face
- (face-name (cdr (car rest)))
- (face-id (cdr (car rest)))
- nil nil nil nil nil))
- (face-fill-in (car (car rest)) global frame))
- (make-face-x-resource-internal (cdr (car rest)) frame t)
- (setq rest (cdr rest)))
- (if (null visibility-spec)
- (make-frame-visible frame)
- (modify-frame-parameters frame (list visibility-spec)))
- (setq success t)
- frame)
- (or success
- (delete-frame frame))))))
+ ;; Read this frame's geometry resource, if it has an explicit name,
+ ;; and put the specs into PARAMETERS.
+ (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"))))
+ (if res-geometry
+ (let ((parsed (x-parse-geometry res-geometry)))
+ ;; If the resource specifies a position,
+ ;; call the position and size "user-specified".
+ (if (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)))))
+ (let (frame)
+ (if (null global-face-data)
+ (progn
+ (setq frame (x-create-frame parameters))
+ (frame-set-background-mode frame))
+ (let* ((visibility-spec (assq 'visibility parameters))
+ success faces rest)
+ (setq frame (x-create-frame (cons '(visibility . nil) parameters)))
+ (frame-set-background-mode frame)
+ (unwind-protect
+ (progn
+
+ ;; Copy the face alist, copying the face vectors
+ ;; and emptying out their attributes.
+ (setq faces
+ (mapcar '(lambda (elt)
+ (cons (car elt)
+ (vector 'face
+ (face-name (cdr elt))
+ (face-id (cdr elt))
+ nil nil nil nil nil)))
+ global-face-data))
+ (set-frame-face-alist frame faces)
+
+ ;; Handle the reverse-video frame parameter
+ ;; and X resource. x-create-frame does not handle this one.
+ (if (cdr (or (assq 'reverse parameters)
+ (assq 'reverse default-frame-alist)
+ (let ((resource (x-get-resource "reverseVideo"
+ "ReverseVideo")))
+ (if resource
+ (cons nil (member (downcase resource)
+ '("on" "true")))))))
+ (let* ((params (frame-parameters frame))
+ (bg (cdr (assq 'foreground-color params)))
+ (fg (cdr (assq 'background-color params))))
+ (modify-frame-parameters frame
+ (list (cons 'foreground-color fg)
+ (cons 'background-color bg)))
+ (if (equal bg (cdr (assq 'border-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'border-color fg))))
+ (if (equal bg (cdr (assq 'mouse-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'mouse-color fg))))
+ (if (equal bg (cdr (assq 'cursor-color params)))
+ (modify-frame-parameters frame
+ (list (cons 'cursor-color fg))))))
+
+ ;; Set up faces from the defface information
+ (mapcar (lambda (symbol)
+ (let ((spec (or (get symbol 'saved-face)
+ (get symbol 'face-defface-spec))))
+ (when spec
+ (face-spec-set symbol spec frame))))
+ (face-list))
+
+ ;; Set up faces from the global face data.
+ (setq rest faces)
+ (while rest
+ (let* ((face (car (car rest)))
+ (global (cdr (assq face global-face-data))))
+ (face-fill-in face global frame))
+ (setq rest (cdr rest)))
+
+ ;; Set up faces from the X resources.
+ (setq rest faces)
+ (while rest
+ (make-face-x-resource-internal (cdr (car rest)) frame t)
+ (setq rest (cdr rest)))
+
+ ;; Make the frame visible, if desired.
+ (if (null visibility-spec)
+ (make-frame-visible frame)
+ (modify-frame-parameters frame (list visibility-spec)))
+ (setq success t))
+ (or success
+ (delete-frame frame)))))
+ frame))
+
+(defcustom frame-background-mode nil
+ "*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 (default) if you want Emacs to
+examine the brightness for you."
+ :group 'faces
+ :type '(choice (choice-item dark)
+ (choice-item light)
+ (choice-item :tag "default" nil)))
+
+(defun frame-set-background-mode (frame)
+ "Set up the `background-mode' and `display-type' frame parameters for FRAME."
+ (let ((bg-resource (x-get-resource ".backgroundMode"
+ "BackgroundMode"))
+ (params (frame-parameters frame))
+ (bg-mode))
+ (setq bg-mode
+ (cond (frame-background-mode)
+ (bg-resource (intern (downcase bg-resource)))
+ ((< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))
+ 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))
+ 'dark)
+ (t 'light)))
+ (modify-frame-parameters frame
+ (list (cons 'background-mode bg-mode)
+ (cons 'display-type
+ (cond ((x-display-color-p frame)
+ 'color)
+ ((x-display-grayscale-p frame)
+ 'grayscale)
+ (t 'mono)))))))
;; Update a frame's faces when we change its default font.
(defun frame-update-faces (frame)
(condition-case nil
(let ((foreground (face-foreground data))
(background (face-background data))
- (font (face-font data)))
+ (font (face-font data))
+ (stipple (face-stipple data)))
(set-face-underline-p face (face-underline-p data) frame)
(if foreground
(face-try-color-list 'set-face-foreground
(italic
(make-face-italic face frame))))
(if font
- (set-face-font face font frame))))
+ (set-face-font face font frame)))
+ (if stipple
+ (set-face-stipple face stipple frame)))
(error nil)))
;; Assuming COLOR is a valid color name,
;; return t if it can be displayed on FRAME.
(defun face-color-supported-p (frame color background-p)
- (or (x-display-color-p frame)
- ;; A black-and-white display can implement these.
- (member color '("black" "white"))
- ;; A black-and-white display can fake these for background.
- (and background-p
- (member color '("gray" "gray1" "gray3")))
- ;; A grayscale display can implement colors that are gray (more or less).
- (and (x-display-grayscale-p frame)
- (let* ((values (x-color-values color frame))
- (r (nth 0 values))
- (g (nth 1 values))
- (b (nth 2 values)))
- (and (< (abs (- r g)) (/ (abs (+ r g)) 20))
- (< (abs (- g b)) (/ (abs (+ g b)) 20))
- (< (abs (- b r)) (/ (abs (+ b r)) 20)))))))
+ (and window-system
+ (or (x-display-color-p frame)
+ ;; A black-and-white display can implement these.
+ (member color '("black" "white"))
+ ;; A black-and-white display can fake gray for background.
+ (and background-p
+ (face-color-gray-p color frame))
+ ;; A grayscale display can implement colors that are gray (more or less).
+ (and (x-display-grayscale-p frame)
+ (face-color-gray-p color frame)))))
;; Use FUNCTION to store a color in FACE on FRAME.
;; COLORS is either a single color or a list of colors.
(setq colors (cdr colors)))))))
;; If we are already using x-window frames, initialize faces for them.
-(if (eq (framep (selected-frame)) 'x)
+(if (memq (framep (selected-frame)) '(x w32))
(face-initialize))
(provide 'faces)