;;; faces.el --- Lisp faces
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
If the optional fourth argument NEW-FRAME is given,
copy the information from face OLD-FACE on frame FRAME
-to NEW-FACE on frame NEW-FRAME."
+to NEW-FACE on frame NEW-FRAME. In this case, FRAME may not be nil."
(let ((inhibit-quit t))
(if (null frame)
(progn
+ (when new-frame
+ (error "Copying face %s from all frames to one frame"
+ old-face))
+ (make-empty-face new-face)
(dolist (frame (frame-list))
(copy-face old-face new-face frame))
(copy-face old-face new-face t))
+ (make-empty-face new-face)
(internal-copy-lisp-face old-face new-face frame new-frame))
new-face))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun facep (face)
- "Return non-nil if FACE is a face name or internal face object.
-Return nil otherwise. A face name can be a string or a symbol.
-An internal face object is a vector of the kind used internally
-to record face data."
+ "Return non-nil if FACE is a face name; nil otherwise.
+A face name can be a string or a symbol."
(internal-lisp-face-p face))
If FRAME is t, report on the defaults for face FACE (for new frames).
If FRAME is omitted or nil, use the selected frame."
(let ((attrs
- '(:family :width :height :weight :slant :foreground
- :background :underline :overline :strike-through
- :box :inverse-video))
+ (delq :inherit (mapcar 'car face-attribute-name-alist)))
(differs nil))
(while (and attrs (not differs))
(let* ((attr (pop attrs))
(symbol-name (check-face face)))
+(defun face-all-attributes (face &optional frame)
+ "Return an alist stating the attributes of FACE.
+Each element of the result has the form (ATTR-NAME . ATTR-VALUE).
+Normally the value describes the default attributes,
+but if you specify FRAME, the value describes the attributes
+of FACE on FRAME."
+ (mapcar (lambda (pair)
+ (let ((attr (car pair)))
+ (cons attr (face-attribute face attr (or frame t)))))
+ face-attribute-name-alist))
+
(defun face-attribute (face attribute &optional frame inherit)
"Return the value of FACE's ATTRIBUTE on FRAME.
If the optional argument FRAME is given, report on face FACE in that 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)
(re-search-backward ": \\([^:]+\\)" nil t)
(help-xref-button 1 'help-face attr)))
(insert "\n")))))
- (terpri)))
- (print-help-return-message))))
+ (terpri))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq attrs (cdr attrs)))))
-(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 (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 (or frame t)))
+(defun face-spec-set (face spec &optional for-defface)
+ "Set FACE's face spec, which controls its appearance, to SPEC>
+If FOR-DEFFACE is t, set the base spec, the one that `defface'
+ and Custom set. (In that case, the caller must put it in the
+ appropriate property, because that depends on the caller.)
+If FOR-DEFFACE is nil, set the overriding spec (and store it
+ in the `face-override-spec' property of FACE).
+
+The appearance of FACE is controlled by the base spec,
+by any custom theme specs on top of that, and by the
+the overriding spec on top of all the rest.
+
+FOR-DEFFACE can also be a frame, in which case we set the
+frame-specific attributes of FACE for that frame based on SPEC.
+That usage is deprecated.
+
+See `defface' for information about the format and meaning of SPEC."
+ (if (framep for-defface)
+ ;; Handle the deprecated case where third arg is a frame.
+ (face-spec-set-2 face for-defface spec)
+ (if for-defface
+ ;; When we reset the face based on its custom spec, then it is
+ ;; unmodified as far as Custom is concerned.
+ (put (or (get face 'face-alias) face) 'face-modified nil)
+ ;; When we change a face based on a spec from outside custom,
+ ;; record it for future frames.
+ (put (or (get face 'face-alias) face) 'face-override-spec spec))
+;;; RMS 29 dec 2007: Perhaps this code should be reinstated.
+;;; That depends on whether the overriding spec
+;;; or the default face attributes
+;;; should take priority.
+;;; ;; Clear all the new-frame default attributes 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))))
+ ;; Reset each frame according to the rules implied by all its specs.
+ (dolist (frame (frame-list))
+ (face-spec-recalc face frame))))
+
+(defun face-spec-recalc (face frame)
+ "Reset the face attributes of FACE on FRAME according to its specs.
+This applies the defface/custom spec first, then the custom theme specs,
+then the override spec."
+ (face-spec-reset-face face frame)
+ (let ((face-sym (or (get face 'face-alias) face)))
+ (face-spec-set-2 face frame
+ (face-user-default-spec face))
+ (let ((theme-faces (reverse (get face-sym 'theme-face))))
+ (dolist (spec theme-faces)
+ (face-spec-set-2 face frame (cadr spec))))
+ (face-spec-set-2 face frame (get face-sym 'face-override-spec))))
+
+(defun face-spec-set-2 (face frame spec)
+ "Set the face attributes of FACE on FRAME according to SPEC."
+ (let* ((attrs (face-spec-choose spec frame)))
(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
- ;; 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)))))
- (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)
- ;; Set each frame according to the rules implied by SPEC.
- (dolist (frame (frame-list))
- (face-spec-set face spec frame))))
-
+ (set-face-attribute face frame attribute value)))
+ (setq attrs (cdr (cdr attrs))))))
(defun face-attr-match-p (face attrs &optional frame)
"Return t if attributes of FACE match values in plist ATTRS.
(get face 'saved-face)
(face-default-spec face)))
-(defsubst face-normalize-spec (spec)
- "Return a normalized face-spec of SPEC."
- (let (normalized-spec)
- (while spec
- (let ((attribute (car spec))
- (value (car (cdr spec))))
- ;; 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))))
- (when attribute
- (push attribute normalized-spec)
- (push value normalized-spec)))
- (setq spec (cdr (cdr spec))))
- (nreverse normalized-spec)))
-
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Frame-type independent color support.
(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.
(let ((locally-modified-faces nil))
;; Before modifying the frame parameters, we collect a list of
;; faces that don't match what their face-spec says they should
- ;; look like; we then avoid changing these faces below. A
- ;; negative list is used on the assumption that most faces will
+ ;; look like; we then avoid changing these faces below.
+ ;; These are the faces whose attributes were modified on FRAME.
+ ;; We use a negative list on the assumption that most faces will
;; be unmodified, so we can avoid consing in the common case.
(dolist (face (face-list))
- (when (not (face-spec-match-p face
- (face-normalize-spec
- (face-user-default-spec face))
- (selected-frame)))
- (push face locally-modified-faces)))
+ (and (not (get face 'face-override-spec))
+ (not (face-spec-match-p face
+ (face-user-default-spec face)
+ (selected-frame)))
+ (push face locally-modified-faces)))
;; Now change to the new frame parameters
(modify-frame-parameters frame
(list (cons 'background-mode bg-mode)
;; parameters, unless they have been locally modified.
(dolist (face (face-list))
(unless (memq face locally-modified-faces)
- (face-spec-set face (face-user-default-spec face) frame)))))))
+ (face-spec-recalc face frame)))))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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.
(dolist (face (delq 'default (face-list)))
(condition-case ()
(progn
- (face-spec-set face (face-user-default-spec face) frame)
+ (face-spec-recalc face frame)
(if (memq (window-system frame) '(x w32 mac))
(make-face-x-resource-internal face frame))
(internal-merge-in-global-face face frame))
(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.
HCoop / bpt / emacs.git / blobdiff