;; 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)) color
- ;; Check for supportedness for foreground, not for background!
+ ;; 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!
(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))
+ (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 ")))
+ (all-frames-p (y-or-n-p (concat "Modify face " face " in all frames "))))
(message "Face %s: %s" face
(mapconcat 'identity
(delq nil
(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.
(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)
+ (if (or (eq window-system 'x) (eq window-system 'win32))
(make-face-x-resource-internal face))
;; add to menu
(if (fboundp 'facemenu-add-new-face)
(cond ((null frame)
(let ((frames (frame-list)))
(while frames
- (if (eq (framep (car frames)) 'x)
+ (if (or (eq (framep (car frames)) 'x) (eq (framep (car frames)) 'win32))
(make-face-x-resource-internal (face-name face)
(car frames) set-anyway))
(setq frames (cdr frames)))))
(cdr (assq 'font (frame-parameters (selected-frame))))))
(defun x-frob-font-weight (font which)
- (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))))
- ((or (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))))))
+ (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))))
+ ((or (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)))))))
(defun x-frob-font-slant (font which)
- (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))))
- ((or (string-match x-font-regexp-head font)
- (string-match x-font-regexp-slant font))
- (concat (substring font 0 (match-beginning 1)) which
- (substring font (match-end 1))))))
+ (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))))
+ ((or (string-match x-font-regexp-head font)
+ (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.
;; 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 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))))
+ (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 (or (eq (framep (selected-frame)) 'x) (eq (framep (selected-frame)) 'win32))
(face-initialize))
(provide 'faces)