X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/72e6f142bf3a325d1eb5b590f402d5ae6a0b61f1..139bbb9cc4db48696ce8c48b8dd6ce09c2c07594:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index a234c90233..d02e40a9b4 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1,7 +1,7 @@ ;;; faces.el --- Lisp faces -;; Copyright (C) 1992,1993,1994,1995,1996,1998,1999,2000,2001,2002,2004 -;; Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, +;; 2002, 2003, 2004, 2005 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: internal @@ -20,8 +20,8 @@ ;; 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, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -183,10 +183,7 @@ Return nil if there is no such face. If the optional argument FRAME is given, this gets the face NAME for that frame; otherwise, it uses the selected frame. If FRAME is the symbol t, then the global, non-frame face is returned. -If NAME is already a face, it is simply returned. - -This function is defined for compatibility with Emacs 20.2. It -should not be used anymore." +If NAME is already a face, it is simply returned." (facep name)) (make-obsolete 'internal-find-face 'facep "21.1") @@ -207,7 +204,10 @@ If NAME is already a face, it is simply returned." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun facep (face) - "Return non-nil if FACE is a face name." + "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." (internal-lisp-face-p face)) @@ -225,7 +225,8 @@ Value is FACE." (defun face-id (face &optional frame) "Return the internal ID of face with name FACE. -If optional argument FRAME is nil or omitted, use the selected frame." +The optional argument FRAME is ignored, since the internal face ID +of a face name is the same for all frames." (check-face face) (get face 'face)) @@ -233,8 +234,8 @@ If optional argument FRAME is nil or omitted, use the selected frame." (defun face-equal (face1 face2 &optional frame) "Non-nil if faces FACE1 and FACE2 are equal. Faces are considered equal if all their attributes are equal. -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 the optional argument FRAME is given, report on FACE1 and FACE2 in that frame. +If FRAME is t, report on the defaults for FACE1 and FACE2 (for new frames). If FRAME is omitted or nil, use the selected frame." (internal-lisp-face-equal-p face1 face2 frame)) @@ -384,7 +385,7 @@ completely specified)." (defun face-attribute-merged-with (attribute value faces &optional frame) "Merges ATTRIBUTE, initially VALUE, with faces from FACES until absolute. FACES may be either a single face or a list of faces. -\[This is an internal function]" +\[This is an internal function.]" (cond ((not (face-attribute-relative-p attribute value)) value) ((null faces) @@ -515,8 +516,17 @@ Use `face-attribute' for finer control." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun face-documentation (face) - "Get the documentation string for FACE." - (get face 'face-documentation)) + "Get the documentation string for FACE. +If FACE is a face-alias, get the documentation for the target face." + (let ((alias (get face 'face-alias)) + doc) + (if alias + (progn + (setq doc (get alias 'face-documentation)) + (format "%s is an alias for the face `%s'.%s" face alias + (if doc (format "\n%s" doc) + ""))) + (get face 'face-documentation)))) (defun set-face-documentation (face string) @@ -663,7 +673,7 @@ like an underlying face would be, with higher priority than underlying faces." (setq args (purecopy args)) ;; If we set the new-frame defaults, this face is modified outside Custom. (if (memq where '(0 t)) - (put face 'face-modified t)) + (put (or (get face 'face-alias) face) 'face-modified t)) (while args (internal-set-lisp-face-attribute face (car args) (purecopy (cadr args)) @@ -760,31 +770,22 @@ and DATA is a string, containing the raw bits of the bitmap." (set-face-attribute face frame :stipple (or stipple 'unspecified))) -(defun set-face-underline (face underline &optional frame) +(defun set-face-underline-p (face underline-p &optional frame) "Specify whether face FACE is underlined. UNDERLINE nil means FACE explicitly doesn't underline. UNDERLINE non-nil means FACE explicitly does underlining with the same of the foreground color. If UNDERLINE is a string, underline with the color named UNDERLINE. FRAME nil or not specified means change face on all frames. -Use `set-face-attribute' to ``unspecify'' underlining." - (interactive - (let ((list (read-face-and-attribute :underline))) - (list (car list) (eq (car (cdr list)) t)))) - (set-face-attribute face frame :underline underline)) - - -(defun set-face-underline-p (face underline-p &optional frame) - "Specify whether face FACE is underlined. -UNDERLINE-P nil means FACE explicitly doesn't underline. -UNDERLINE-P non-nil means FACE explicitly does underlining. -FRAME nil or not specified means change face on all frames. Use `set-face-attribute' to ``unspecify'' underlining." (interactive (let ((list (read-face-and-attribute :underline))) (list (car list) (eq (car (cdr list)) t)))) (set-face-attribute face frame :underline underline-p)) +(define-obsolete-function-alias 'set-face-underline + 'set-face-underline-p "22.1") + (defun set-face-inverse-video-p (face inverse-video-p &optional frame) "Specify whether face FACE is in inverse video. @@ -856,8 +857,13 @@ If MULTIPLE is non-nil, return a list of faces (possibly only one). Otherwise, return a single face." (let ((faceprop (or (get-char-property (point) 'read-face-name) (get-char-property (point) 'face))) + (aliasfaces nil) + (nonaliasfaces nil) faces) - ;; Make a list of the named faces that the `face' property uses. + ;; Try to get a face name from the buffer. + (if (memq (intern-soft (thing-at-point 'symbol)) (face-list)) + (setq faces (list (intern-soft (thing-at-point 'symbol))))) + ;; Add the named faces that the `face' property uses. (if (and (listp faceprop) ;; Don't treat an attribute spec as a list of faces. (not (keywordp (car faceprop))) @@ -867,32 +873,41 @@ Otherwise, return a single face." (push f faces))) (if (symbolp faceprop) (push faceprop faces))) - ;; If there are none, try to get a face name from the buffer. - (if (and (null faces) - (memq (intern-soft (thing-at-point 'symbol)) (face-list))) - (setq faces (list (intern-soft (thing-at-point 'symbol))))) + (delete-dups faces) + + ;; Build up the completion tables. + (mapatoms (lambda (s) + (if (custom-facep s) + (if (get s 'face-alias) + (push (symbol-name s) aliasfaces) + (push (symbol-name s) nonaliasfaces))))) ;; If we only want one, and the default is more than one, ;; discard the unwanted ones now. (unless multiple (if faces (setq faces (list (car faces))))) + (require 'crm) (let* ((input ;; Read the input. - (completing-read + (completing-read-multiple (if (or faces string-describing-default) (format "%s (default %s): " prompt - (if faces (mapconcat 'symbol-name faces ", ") + (if faces (mapconcat 'symbol-name faces ",") string-describing-default)) (format "%s: " prompt)) - obarray 'custom-facep t)) + (complete-in-turn nonaliasfaces aliasfaces) + nil t nil nil + (if faces (mapconcat 'symbol-name faces ",")))) ;; Canonicalize the output. (output - (if (equal input "") - faces - (if (stringp input) - (list (intern input)) - input)))) + (cond ((or (equal input "") (equal input '(""))) + faces) + ((stringp input) + (mapcar 'intern (split-string input ", *" t))) + ((listp input) + (mapcar 'intern input)) + (input)))) ;; Return either a list of faces or just one face. (if multiple output @@ -1013,7 +1028,7 @@ name of the attribute for prompting. Value is the new attribute value." ((member new-value '("unspecified-fg" "unspecified-bg")) new-value) (t - (string-to-int new-value))))) + (string-to-number new-value))))) (defun read-face-attribute (face attribute &optional frame) @@ -1072,7 +1087,7 @@ of a global face. Value is the new attribute value." (defun read-face-font (face &optional frame) "Read the name of a font for FACE on FRAME. -If optional argument FRAME Is nil or omitted, use the selected frame." +If optional argument FRAME is nil or omitted, use the selected frame." (let ((completion-ignore-case t)) (completing-read (format "Set font attributes of face `%s' from font: " face) (x-list-fonts "*" nil frame)))) @@ -1080,7 +1095,7 @@ If optional argument FRAME Is nil or omitted, use the selected frame." (defun read-all-face-attributes (face &optional frame) "Interactively read all attributes for FACE. -If optional argument FRAME Is nil or omitted, use the selected frame. +If optional argument FRAME is nil or omitted, use the selected frame. Value is a property list of attribute names and new values." (let (result) (dolist (attribute face-attribute-name-alist result) @@ -1094,7 +1109,7 @@ Value is a property list of attribute names and new values." If optional argument FRAME is nil or omitted, modify the face used for newly created frame, i.e. the global face. For non-interactive use, `set-face-attribute' is preferred. -When called from elisp, if FACE is nil, all arguments but FRAME are ignored +When called from Lisp, if FACE is nil, all arguments but FRAME are ignored and the face and its settings are obtained by querying the user." (interactive) (if face @@ -1143,15 +1158,34 @@ Value is a list (FACE NEW-VALUE) where FACE is the face read ;; conflict with Lucid, which uses that name differently. (defvar help-xref-stack) -(defun list-faces-display () +(defun list-faces-display (&optional regexp) "List all faces, using the same sample text in each. The sample text is a string that comes from the variable -`list-faces-sample-text'." - (interactive) - (let ((faces (sort (face-list) #'string-lessp)) - (face nil) +`list-faces-sample-text'. + +If REGEXP is non-nil, list only those faces with names matching +this regular expression. When called interactively with a prefix +arg, prompt for a regular expression." + (interactive (list (and current-prefix-arg + (read-string "List faces matching regexp: ")))) + (let ((all-faces (zerop (length regexp))) (frame (selected-frame)) + (max-length 0) + faces line-format disp-frame window face-name) + ;; We filter and take the max length in one pass + (setq faces + (delq nil + (mapcar (lambda (f) + (let ((s (symbol-name f))) + (when (or all-faces (string-match regexp s)) + (setq max-length (max (length s) max-length)) + f))) + (sort (face-list) #'string-lessp)))) + (unless faces + (error "No faces matching \"%s\"" regexp)) + (setq max-length (1+ max-length) + line-format (format "%%-%ds" max-length)) (with-output-to-temp-buffer "*Faces*" (save-excursion (set-buffer standard-output) @@ -1164,16 +1198,15 @@ The sample text is a string that comes from the variable "\\[help-follow] on a face name to customize it\n" "or on its sample text for a description of the face.\n\n"))) (setq help-xref-stack nil) - (while faces - (setq face (car faces)) - (setq faces (cdr faces)) + (dolist (face faces) (setq face-name (symbol-name face)) - (insert (format "%25s " face-name)) + (insert (format line-format 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) + (setq help-xref-stack-item `(list-faces-display ,regexp)) (help-xref-button 0 'help-customize-face face))) (let ((beg (point)) (line-beg (line-beginning-position))) @@ -1192,7 +1225,7 @@ The sample text is a string that comes from the variable (goto-char beg) (forward-line 1) (while (not (eobp)) - (insert " ") + (insert-char ?\s max-length) (forward-line 1)))) (goto-char (point-min))) (print-help-return-message)) @@ -1208,6 +1241,7 @@ The sample text is a string that comes from the variable (copy-face (car faces) (car faces) frame disp-frame) (setq faces (cdr faces))))))) + (defun describe-face (face &optional frame) "Display the properties of face FACE on FRAME. Interactively, FACE defaults to the faces of the character after point @@ -1246,21 +1280,43 @@ If FRAME is omitted or nil, use the selected frame." (insert "Face: " (symbol-name f)) (if (not (facep f)) (insert " undefined face.\n") - (let ((customize-label "customize this face")) + (let ((customize-label "customize this face") + file-name) (princ (concat " (" customize-label ")\n")) (insert "Documentation: " (or (face-documentation f) "Not documented as a face.") - "\n\n") + "\n") (with-current-buffer standard-output (save-excursion (re-search-backward (concat "\\(" customize-label "\\)") nil t) (help-xref-button 1 'help-customize-face f))) + ;; The next 4 sexps are copied from describe-function-1 + ;; and simplified. + (setq file-name (symbol-file f 'defface)) + (when file-name + (princ "Defined in `") + (princ file-name) + (princ "'") + ;; Make a hyperlink to the library. + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-face-def f file-name)) + (princ ".") + (terpri) + (terpri)) (dolist (a attrs) (let ((attr (face-attribute f (car a) frame))) - (insert (make-string (- max-width (length (cdr a))) ?\ ) - (cdr a) ": " (format "%s" attr) "\n"))))) + (insert (make-string (- max-width (length (cdr a))) ?\s) + (cdr a) ": " (format "%s" attr)) + (if (and (eq (car a) :inherit) + (not (eq attr 'unspecified))) + ;; Make a hyperlink to the parent face. + (save-excursion + (re-search-backward ": \\([^:]+\\)" nil t) + (help-xref-button 1 'help-face attr))) + (insert "\n"))))) (terpri))) (print-help-return-message)))) @@ -1273,7 +1329,7 @@ If FRAME is omitted or nil, use the selected frame." ;; face implementation. (defun face-attr-construct (face &optional frame) - "Return a defface-style attribute list for FACE on FRAME. + "Return a `defface'-style attribute list for FACE on FRAME. Value is a property list of pairs ATTRIBUTE VALUE for all specified face attributes of FACE where ATTRIBUTE is the attribute name and VALUE is the specified value of that attribute." @@ -1402,7 +1458,7 @@ If SPEC is nil, do nothing." ;; When we reset the face based on its spec, then it is unmodified ;; as far as Custom is concerned. (if (null frame) - (put face 'face-modified nil))) + (put (or (get face 'face-alias) face) 'face-modified nil))) (defun face-attr-match-p (face attrs &optional frame) @@ -1436,7 +1492,8 @@ If there is no default for FACE, return nil." (defsubst face-user-default-spec (face) "Return the user's customized face-spec for FACE, or the default if none. If there is neither a user setting nor a default for FACE, return nil." - (or (get face 'saved-face) + (or (get face 'customized-face) + (get face 'saved-face) (face-default-spec face))) @@ -1508,9 +1565,9 @@ If omitted or nil, that stands for the selected frame's display." (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. Don't set this variable with `setq'; +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. Don't set this variable with `setq'; this won't have the expected effect." :group 'faces :set #'(lambda (var value) @@ -1521,6 +1578,13 @@ this won't have the expected effect." (choice-item light) (choice-item :tag "default" nil))) +(defvar default-frame-background-mode nil + "Internal variable for the default brightness of the background. +Emacs sets it automatically depending on the terminal type. +The value `nil' means `dark'. If Emacs runs in non-windowed +mode from `xterm' or a similar terminal emulator, the value is +`light'. On rxvt terminals, the value depends on the environment +variable COLORFGBG.") (defun frame-set-background-mode (frame) "Set up display-dependent faces on FRAME. @@ -1536,13 +1600,13 @@ according to the `background-mode' and `display-type' frame parameters." (intern (downcase bg-resource))) ((and (null window-system) (null bg-color)) ;; No way to determine this automatically (?). - 'dark) + (or default-frame-background-mode 'dark)) ;; Unspecified frame background color can only happen ;; on tty's. ((member bg-color '(unspecified "unspecified-bg")) - 'dark) + (or default-frame-background-mode 'dark)) ((equal bg-color "unspecified-fg") ; inverted colors - 'light) + (if (eq default-frame-background-mode 'light) 'dark 'light)) ((>= (apply '+ (x-color-values bg-color frame)) ;; Just looking at the screen, colors whose ;; values add up to .6 of the white total @@ -1770,8 +1834,8 @@ created." ;; Update the colors of FACE, after FRAME's own colors have been ;; changed. -(defalias 'frame-update-face-colors 'frame-set-background-mode) -(make-obsolete 'frame-update-face-colors 'frame-set-background-mode "21.1") +(define-obsolete-function-alias 'frame-update-face-colors + 'frame-set-background-mode "21.1") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1812,13 +1876,31 @@ created." :box (:line-width -1 :color "grey40" :style nil) :foreground "grey80" :background "grey30")) "Basic mode line face for non-selected windows." - :version "21.4" + :version "22.1" + :group 'modeline + :group 'basic-faces) + +(defface mode-line-highlight + '((((class color) (min-colors 88)) + :box (:line-width 2 :color "grey40" :style released-button)) + (t + :inherit highlight)) + "Basic mode line face for highlighting." + :version "22.1" + :group 'modeline + :group 'basic-faces) + +(defface vertical-border + '((((type tty)) :inherit mode-line-inactive)) + "Face used for vertical window dividers on ttys." + :version "22.1" :group 'modeline :group 'basic-faces) ;; Make `modeline' an alias for `mode-line', for compatibility. (put 'modeline 'face-alias 'mode-line) (put 'modeline-inactive 'face-alias 'mode-line-inactive) +(put 'modeline-highlight 'face-alias 'mode-line-highlight) (defface header-line '((default @@ -1869,11 +1951,17 @@ created." :group 'basic-faces) -(defface minibuffer-prompt '((((background dark)) :foreground "cyan") - (((type pc)) :foreground "magenta") - (t :foreground "dark blue")) - "Face for minibuffer prompts." - :version "21.4" +(defface minibuffer-prompt + '((((background dark)) :foreground "cyan") + ;; Don't use blue because many users of the MS-DOS port customize + ;; their foreground color to be blue. + (((type pc)) :foreground "magenta") + (t :foreground "dark blue")) + "Face for minibuffer prompts. +By default, Emacs automatically adds this face to the value of +`minibuffer-prompt-properties', which is a list of text properties +used to display the prompt text." + :version "22.1" :group 'basic-faces) (setq minibuffer-prompt-properties @@ -1969,7 +2057,7 @@ Note: Other faces cannot inherit from the cursor face." ;; because in some cases the display engine will do it's own ;; workaround (to `dim' on ttys) :slant italic)) - "Basic italic font." + "Basic italic face." :group 'basic-faces) @@ -1978,7 +2066,11 @@ Note: Other faces cannot inherit from the cursor face." :group 'basic-faces) -(defface underline '((t :underline t)) +(defface underline '((((supports :underline t)) + :underline t) + (((supports :weight bold)) + :weight bold) + (t :underline t)) "Basic underlined face." :group 'basic-faces) @@ -2001,7 +2093,7 @@ Note: Other faces cannot inherit from the cursor face." (defface secondary-selection '((((class color) (min-colors 88) (background light)) - :background "yellow") + :background "yellow1") (((class color) (min-colors 88) (background dark)) :background "SkyBlue4") (((class color) (min-colors 16) (background light)) @@ -2027,20 +2119,48 @@ Note: Other faces cannot inherit from the cursor face." (defface trailing-whitespace '((((class color) (background light)) - :background "red") + :background "red1") (((class color) (background dark)) - :background "red") + :background "red1") (t :inverse-video t)) "Basic face for highlighting trailing whitespace." :version "21.1" - :group 'font-lock ; like `show-trailing-whitespace' + :group 'whitespace ; like `show-trailing-whitespace' :group 'basic-faces) -(defface escape-glyph '((((background dark)) :foreground "cyan") - (((type pc)) :foreground "magenta") - (t :foreground "blue")) +(defface escape-glyph + '((((background dark)) :foreground "cyan") + ;; See the comment in minibuffer-prompt for + ;; the reason not to use blue on MS-DOS. + (((type pc)) :foreground "magenta") + ;; red4 is too dark, but some say blue is too loud. + ;; brown seems to work ok. -- rms. + (t :foreground "brown")) "Face for characters displayed as ^-sequences or \-sequences." - :group 'basic-faces) + :group 'basic-faces + :version "22.1") + +(defface nobreak-space + '((((class color) (min-colors 88)) :inherit escape-glyph :underline t) + (((class color) (min-colors 8)) :background "magenta") + (t :inverse-video t)) + "Face for displaying nobreak space." + :group 'basic-faces + :version "22.1") + +(defface shadow + '((((class color grayscale) (min-colors 88) (background light)) + :foreground "grey50") + (((class color grayscale) (min-colors 88) (background dark)) + :foreground "grey70") + (((class color) (min-colors 8) (background light)) + :foreground "green") + (((class color) (min-colors 8) (background dark)) + :foreground "yellow")) + "Basic face for shadowed text." + :group 'basic-faces + :version "22.1") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Manipulating font names. @@ -2220,5 +2340,5 @@ If that can't be done, return nil." (provide 'faces) -;;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6 +;; arch-tag: 19a4759f-2963-445f-b004-425b9aadd7d6 ;;; faces.el ends here