;; Copyright (C) 1992-1996, 1998-2014 Free Software Foundation, Inc.
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
;; Package: emacs
(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)
"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)
(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)
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.
(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)))))
\f
\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 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
- "\\<help-mode-map>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)))))))
-
-\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Face specifications (defface).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))
(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)
(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."
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)
(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))
(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
(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.