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)
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
- (interactive (internal-face-interactive "stipple"))
+ (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
(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 ")))
+ ;; 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
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 (or (eq window-system 'x) (eq window-system 'win32))
- (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 (or (eq (framep (car frames)) 'x) (eq (framep (car frames)) 'win32))
+ (if (memq (framep (car frames)) '(x w32))
(make-face-x-resource-internal (face-name face)
(car frames) set-anyway))
(setq frames (cdr frames)))))
(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)
(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)
;; for related fonts.
"*"
(substring font (match-end x-font-regexp-adstyle-subnum))))
- ((or (string-match x-font-regexp-head font)
- (string-match x-font-regexp-weight font))
+ ((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)))))))
;; for related fonts.
"*"
(substring font (match-end x-font-regexp-adstyle-subnum))))
- ((or (string-match x-font-regexp-head font)
- (string-match x-font-regexp-slant 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)))))))
(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"))))
+ (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.
(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")))
- parsed)
+ (res-geometry (if name (x-get-resource "geometry" "Geometry"))))
(if res-geometry
- (progn
- (setq parsed (x-parse-geometry 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 (cons '(user-position . t)
- (cons '(user-size . t) 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)))))
+ (setq parameters (append parameters default-frame-alist parsed)))))
(let (frame)
(if (null global-face-data)
- (setq frame (x-create-frame parameters))
+ (progn
+ (setq frame (x-create-frame parameters))
+ (frame-set-background-mode frame))
(let* ((visibility-spec (assq 'visibility parameters))
- (faces (copy-alist global-face-data))
- success
- (rest faces))
+ 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"
(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.
+
+ ;; 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
- (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)))
+
+ ;; 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)))))
- ;; Set up the background-mode frame parameter
- ;; so that programs can decide good ways of highlighting
- ;; on this frame.
- (let ((bg-resource (x-get-resource ".backgroundMode"
- "BackgroundMode"))
- (params (frame-parameters frame))
- (bg-mode))
- (setq bg-mode
- (cond (bg-resource (intern (downcase bg-resource)))
- ((< (apply '+ (x-color-values
- (cdr (assq 'background-color params))
- frame))
- (/ (apply '+ (x-color-values "white" frame)) 3))
- '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))))))
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)
(let* ((faces global-face-data)
(setq colors (cdr colors)))))))
;; If we are already using x-window frames, initialize faces for them.
-(if (or (eq (framep (selected-frame)) 'x) (eq (framep (selected-frame)) 'win32))
+(if (memq (framep (selected-frame)) '(x w32))
(face-initialize))
(provide 'faces)