X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/764ec9e5f0adaff96b52252eea71eb30ef7cefa1..HEAD:/lisp/faces.el diff --git a/lisp/faces.el b/lisp/faces.el index 460fddf9cc..f78267cc09 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -2,7 +2,7 @@ ;; Copyright (C) 1992-1996, 1998-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal ;; Package: emacs @@ -35,6 +35,26 @@ the terminal-initialization file to be loaded." (string :tag "Name of directory with term files")) :group 'terminals) +(defcustom term-file-aliases + '(("apollo" . "vt100") + ("vt102" . "vt100") + ("vt125" . "vt100") + ("vt201" . "vt200") + ("vt220" . "vt200") + ("vt240" . "vt200") + ("vt300" . "vt200") + ("vt320" . "vt200") + ("vt400" . "vt200") + ("vt420" . "vt200") + ) + "Alist of terminal type aliases. +Entries are of the form (TYPE . ALIAS), where both elements are strings. +This means to treat a terminal of type TYPE as if it were of type ALIAS." + :type '(alist :key-type (string :tag "Terminal") + :value-type (string :tag "Alias")) + :group 'terminals + :version "24.5") + (declare-function xw-defined-colors "term/common-win" (&optional frame)) (defvar help-xref-stack-item) @@ -129,13 +149,11 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc." "Return a list of all defined faces." (mapcar #'car face-new-frame-defaults)) -(defun make-face (face &optional no-init-from-resources) +(defun make-face (face) "Define a new face with name FACE, a symbol. Do not call this directly from Lisp code; use `defface' instead. -If NO-INIT-FROM-RESOURCES is non-nil, don't initialize face -attributes from X resources. If FACE is already known as a face, -leave it unmodified. Return FACE." +If FACE is already known as a face, leave it unmodified. Return FACE." (interactive (list (read-from-minibuffer "Make face: " nil nil t 'face-name-history))) (unless (facep face) @@ -146,8 +164,7 @@ leave it unmodified. Return FACE." (when (fboundp 'facemenu-add-new-face) (facemenu-add-new-face face)) ;; Define frame-local faces for all frames from X resources. - (unless no-init-from-resources - (make-face-x-resource-internal face))) + (make-face-x-resource-internal face)) face) (defun make-empty-face (face) @@ -155,7 +172,7 @@ leave it unmodified. Return FACE." Do not call this directly from Lisp code; use `defface' instead." (interactive (list (read-from-minibuffer "Make empty face: " nil nil t 'face-name-history))) - (make-face face 'no-init-from-resources)) + (make-face face)) (defun copy-face (old-face new-face &optional frame new-frame) "Define a face named NEW-FACE, which is a copy of OLD-FACE. @@ -334,11 +351,16 @@ specifies an invalid attribute." (defun make-face-x-resource-internal (face &optional frame) "Fill frame-local FACE on FRAME from X resources. -FRAME nil or not specified means do it for all frames." - (if (null frame) - (dolist (frame (frame-list)) - (set-face-attributes-from-resources face frame)) - (set-face-attributes-from-resources face frame))) +FRAME nil or not specified means do it for all frames. + +If `inhibit-x-resources' is non-nil, this function does nothing." + (unless inhibit-x-resources + (dolist (frame (if (null frame) (frame-list) (list frame))) + ;; `x-create-frame' already took care of correctly handling + ;; the reverse video case-- do _not_ touch the default face + (unless (and (eq face 'default) + (frame-parameter frame 'reverse)) + (set-face-attributes-from-resources face frame))))) @@ -1240,205 +1262,6 @@ Value is a list (FACE NEW-VALUE) where FACE is the face read -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Listing faces. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconst list-faces-sample-text - "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "Text string to display as the sample text for `list-faces-display'.") - - -;; The name list-faces would be more consistent, but let's avoid a -;; conflict with Lucid, which uses that name differently. - -(defvar help-xref-stack) -(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'. - -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-regexp "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-p 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-help-window "*Faces*" - (with-current-buffer standard-output - (setq truncate-lines t) - (insert - (substitute-command-keys - (concat - "\\Use " - (if (display-mouse-p) "\\[help-follow-mouse] or ") - "\\[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) - (dolist (face faces) - (setq face-name (symbol-name face)) - (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))) - (insert list-faces-sample-text) - ;; Hyperlink to a help buffer for the face. - (save-excursion - (save-match-data - (search-backward list-faces-sample-text) - (help-xref-button 0 'help-face face))) - (insert "\n") - (put-text-property beg (1- (point)) 'face face) - ;; Make all face commands default to the proper face - ;; anywhere in the line. - (put-text-property line-beg (1- (point)) 'read-face-name face) - ;; If the sample text has multiple lines, line up all of them. - (goto-char beg) - (forward-line 1) - (while (not (eobp)) - (insert-char ?\s max-length) - (forward-line 1)))) - (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 window (get-buffer-window (get-buffer "*Faces*") t)) - (setq disp-frame (if window (window-frame window) - (car (frame-list)))) - (or (eq frame disp-frame) - (dolist (face (face-list)) - (copy-face face face frame disp-frame))))) - - -(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 -and FRAME defaults to the selected frame. - -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 FRAME is omitted or nil, use the selected frame." - (interactive (list (read-face-name "Describe face" - (or (face-at-point t) 'default) - t))) - (let* ((attrs '((:family . "Family") - (:foundry . "Foundry") - (:width . "Width") - (:height . "Height") - (:weight . "Weight") - (:slant . "Slant") - (:foreground . "Foreground") - (:distant-foreground . "DistantForeground") - (:background . "Background") - (:underline . "Underline") - (:overline . "Overline") - (:strike-through . "Strike-through") - (:box . "Box") - (:inverse-video . "Inverse") - (:stipple . "Stipple") - (:font . "Font") - (:fontset . "Fontset") - (:inherit . "Inherit"))) - (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) - attrs)))) - (help-setup-xref (list #'describe-face face) - (called-interactively-p 'interactive)) - (unless face - (setq face 'default)) - (if (not (listp face)) - (setq face (list face))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (dolist (f face) - (if (stringp f) (setq f (intern f))) - ;; We may get called for anonymous faces (i.e., faces - ;; expressed using prop-value plists). Those can't be - ;; usefully customized, so ignore them. - (when (symbolp f) - (insert "Face: " (symbol-name f)) - (if (not (facep f)) - (insert " undefined face.\n") - (let ((customize-label "customize this face") - file-name) - (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) - (princ (concat " (" customize-label ")\n")) - ;; FIXME not sure how much of this belongs here, and - ;; how much in `face-documentation'. The latter is - ;; not used much, but needs to return nil for - ;; undocumented faces. - (let ((alias (get f 'face-alias)) - (face f) - obsolete) - (when alias - (setq face alias) - (insert - (format "\n %s is an alias for the face `%s'.\n%s" - f alias - (if (setq obsolete (get f 'obsolete-face)) - (format " This face is obsolete%s; use `%s' instead.\n" - (if (stringp obsolete) - (format " since %s" obsolete) - "") - alias) - "")))) - (insert "\nDocumentation:\n" - (or (face-documentation face) - "Not documented as a face.") - "\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))) - (setq file-name (find-lisp-object-file-name f 'defface)) - (when file-name - (princ "Defined in `") - (princ (file-name-nondirectory 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))) ?\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))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Face specifications (defface). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1512,13 +1335,15 @@ If FRAME is nil, the current FRAME is used." match)) -(defun face-spec-choose (spec &optional frame) - "Choose the proper attributes for FRAME, out of SPEC. -If SPEC is nil, return nil." +(defun face-spec-choose (spec &optional frame no-match-retval) + "Return the proper attributes for FRAME, out of SPEC. + +If no match is found or SPEC is nil, return nil, unless NO-MATCH-RETVAL +is given, in which case return its value instead." (unless frame (setq frame (selected-frame))) (let ((tail spec) - result defaults) + result defaults match-found) (while tail (let* ((entry (pop tail)) (display (car entry)) @@ -1538,9 +1363,18 @@ If SPEC is nil, return nil." (setq defaults thisval) ;; Otherwise, if it matches, use it. (when (face-spec-set-match-display display frame) - (setq result thisval) - (setq tail nil))))) - (if defaults (append result defaults) result))) + (setq result thisval + tail nil + match-found t))))) + ;; If defaults have been found, it's safe to just append those to the result + ;; list (which at this point will be either nil or contain actual specs) and + ;; return it to the caller. Since there will most definitely be something to + ;; return in this case, there's no need to know/check if a match was found. + (if defaults + (append result defaults) + (if match-found + result + no-match-retval)))) (defun face-spec-reset-face (face &optional frame) @@ -1619,30 +1453,43 @@ function for its other effects." (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." +The following sources are applied in this order: + + face reset to default values if it's the default face, otherwise set + to unspecified (through `face-spec-reset-face') + | + (theme and user customization) + or: if none of the above exist, and none match the current frame or + inherited from the defface spec instead of overwriting it + entirely, the following is applied instead: + (defface default spec) + (X resources (if applicable)) + | + defface override spec" (while (get face 'face-alias) (setq face (get face 'face-alias))) (face-spec-reset-face face frame) ;; If FACE is customized or themed, set the custom spec from ;; `theme-face' records. (let ((theme-faces (get face 'theme-face)) + (no-match-found 0) spec theme-face-applied) (if theme-faces (dolist (elt (reverse theme-faces)) - (setq spec (face-spec-choose (cadr elt) frame)) - (when spec + (setq spec (face-spec-choose (cadr elt) frame no-match-found)) + (unless (eq spec no-match-found) (face-spec-set-2 face frame spec) (setq theme-face-applied t)))) ;; If there was a spec applicable to FRAME, that overrides the ;; defface spec entirely (rather than inheriting from it). If - ;; there was no spec applicable to FRAME, apply the defface spec. + ;; there was no spec applicable to FRAME, apply the defface spec + ;; as well as any applicable X resources. (unless theme-face-applied (setq spec (face-spec-choose (face-default-spec face) frame)) - (face-spec-set-2 face frame spec)) + (face-spec-set-2 face frame spec) + (make-face-x-resource-internal face frame)) (setq spec (face-spec-choose (get face 'face-override-spec) frame)) - (face-spec-set-2 face frame spec)) - (make-face-x-resource-internal face frame)) + (face-spec-set-2 face frame spec))) (defun face-spec-set-2 (face frame spec) "Set the face attributes of FACE on FRAME according to SPEC." @@ -2019,21 +1866,16 @@ Calculate the face definitions using the face specs, custom theme settings, X resources, and `face-new-frame-defaults'. Finally, apply any relevant face attributes found amongst the frame parameters in PARAMETERS." - (let ((window-system-p (memq (window-system frame) '(x w32)))) - ;; The `reverse' is so that `default' goes first. - (dolist (face (nreverse (face-list))) - (condition-case () - (progn - ;; Initialize faces from face spec and custom theme. - (face-spec-recalc face frame) - ;; X resources for the default face are applied during - ;; `x-create-frame'. - (and (not (eq face 'default)) window-system-p - (make-face-x-resource-internal face frame)) - ;; Apply attributes specified by face-new-frame-defaults - (internal-merge-in-global-face face frame)) - ;; Don't let invalid specs prevent frame creation. - (error nil)))) + ;; The `reverse' is so that `default' goes first. + (dolist (face (nreverse (face-list))) + (condition-case () + (progn + ;; Initialize faces from face spec and custom theme. + (face-spec-recalc face frame) + ;; Apply attributes specified by face-new-frame-defaults + (internal-merge-in-global-face face frame)) + ;; Don't let invalid specs prevent frame creation. + (error nil))) ;; Apply attributes specified by frame parameters. (let ((face-params '((foreground-color default :foreground) @@ -2080,7 +1922,7 @@ If PARAMETERS contains a `reverse' parameter, handle that." (unless (terminal-parameter frame 'terminal-initted) (set-terminal-parameter frame 'terminal-initted t) (set-locale-environment nil frame) - (tty-run-terminal-initialization frame)) + (tty-run-terminal-initialization frame nil t)) (frame-set-background-mode frame t) (face-set-after-frame-default frame parameters) (setq success t)) @@ -2107,13 +1949,24 @@ the above example." (defvar tty-setup-hook nil "Hook run after running the initialization function of a new text terminal. +Specifically, `tty-run-terminal-initialization' runs this. This can be used to fine tune the `input-decode-map', for example.") -(defun tty-run-terminal-initialization (frame &optional type) +(defun tty-run-terminal-initialization (frame &optional type run-hook) "Run the special initialization code for the terminal type of FRAME. The optional TYPE parameter may be used to override the autodetected -terminal type to a different value." +terminal type to a different value. + +This consults `term-file-aliases' to map terminal types to their aliases. + +If optional argument RUN-HOOK is non-nil, then as a final step, +this runs the hook `tty-setup-hook'. + +If you set `term-file-prefix' to nil, this function does nothing." (setq type (or type (tty-type frame))) + (let ((alias (tty-find-type + (lambda (typ) (assoc typ term-file-aliases)) type))) + (if alias (setq type (cdr (assoc alias term-file-aliases))))) ;; Load library for our terminal type. ;; User init file can set term-file-prefix to nil to prevent this. (with-selected-frame frame @@ -2135,7 +1988,7 @@ terminal type to a different value." (when (fboundp term-init-func) (funcall term-init-func)) (set-terminal-parameter frame 'terminal-initted term-init-func) - (run-hooks 'tty-setup-hook))))) + (if run-hook (run-hooks 'tty-setup-hook)))))) ;; Called from C function init_display to initialize faces of the ;; dumped terminal frame on startup.